home *** CD-ROM | disk | FTP | other *** search
/ Encyclopedia of Graphics File Formats Companion / GFF_CD.ISO / software / mac / nihimage / nih_src.hqx / V1.54 Source / File2.p < prev    next >
Encoding:
Text File  |  1994-01-31  |  68.8 KB  |  2,611 lines

  1. unit File2;
  2.  
  3. {Routines used by Image for printing plus a few additional File Menu routines.}
  4.  
  5. interface
  6.  
  7.  
  8.     uses
  9.         QuickDraw, Palettes, PrintTraps, globals, Utilities, Graphics, Lut;
  10.  
  11.  
  12.     procedure GetInfo;
  13.     procedure DoPageSetup;
  14.     procedure Print (ShowDialog: boolean);
  15.     procedure SetHalftone;
  16.     function OpenMacPaint (fname: str255; vnum: integer): boolean;
  17.     procedure TypeMismatch (fname: str255);
  18.     procedure SaveAsMacPaint (fname: str255; RefNum: integer);
  19.     function GetTextFile (var name: str255; var RefNum: integer): boolean;
  20.     procedure InitTextInput (name: str255; RefNum: integer);
  21.     procedure GetLineFromText (var rLine: RealLine; var count: integer);
  22.     function ImportTextFile (name: str255; RefNum: integer): boolean;
  23.     procedure PlotXYZ;
  24.     procedure SaveSettings;
  25.     procedure ExportAsText (fname: str255; RefNum: integer);
  26.     procedure ExportMeasurements (fname: str255; RefNum: integer);
  27.     procedure Swap2Bytes (var i: integer);
  28.     function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean;
  29.     function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec): boolean;
  30.     procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt);
  31.     procedure GetTiffColorMap (f: integer);
  32.     function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr;
  33.     function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean;
  34.     function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer;
  35.     procedure SaveLUT (fname: str255; RefNum: integer);
  36.     procedure SaveColorTable (fname: str255; RefNum: integer);
  37.     procedure ExportCoordinates (fname: str255; RefNum: integer);
  38.     procedure SaveOutline (fname: str255; RefNum: integer);
  39.     procedure OpenOutline (fname: str255; RefNum: integer);
  40.     function CheckIO (err: OSerr): integer;
  41.     function GetTIFFParameters (name: str255; RefNum: integer): boolean;
  42.     procedure GetXUnits (UnitsKind: UnitsType);
  43.     procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: double);
  44.  
  45.  
  46. implementation
  47.  
  48.     var
  49.         gstr: str255;
  50.  
  51.  
  52. {$PUSH}
  53. {$D-}
  54.  
  55.     procedure PrintErrCheck;
  56.         var
  57.             err: integer;
  58.             ticks: LongInt;
  59.     begin
  60.         err := PrError;
  61.         if err < 0 then
  62.             beep;
  63.     end;
  64.  
  65.  
  66.     procedure DoPageSetup;
  67.         var
  68.             result: boolean;
  69.     begin
  70.         PrOpen;
  71.         if PrintRecord = nil then begin
  72.                 PrintRecord := THPrint(NewHandle(SizeOF(TPrint)));
  73.                 PrintDefault(PrintRecord);
  74.             end;
  75.         if PrError = NoErr then begin
  76.                 result := PrValidate(PrintRecord);
  77.                 result := PrStlDialog(PrintRecord);
  78.             end;
  79.         PrClose;
  80.     end;
  81.  
  82.  
  83.     procedure PrintHalftone;
  84.         const
  85.             PostScriptBegin = 190;
  86.             PostScriptEnd = 191;
  87.             PostScriptHandle = 192;
  88.             TextIsPostScript = 194;
  89.         var
  90.             HexBufH: handle;
  91.             hloc, vloc, HexCount, iheight, iwidth, hstart, vstart: integer;
  92.             Height, Width, eof, angle, freq: str255;
  93.             aLine: LineType;
  94.             HexBuf: packed array[0..4200] of char;
  95.             err: OSErr;
  96.             table: LookupTable;
  97.  
  98.         procedure PutHEX (byt: integer);
  99.             var
  100.                 i, LowByte, HighByte, tmp: integer;
  101.                 h: char;
  102.         begin
  103.             if not info^.IdentityFunction then
  104.                 byt := table[byt];
  105.             byt := 255 - byt;
  106.             LowByte := byt mod 16;
  107.             byt := byt div 16;
  108.             HighByte := byt mod 16;
  109.             for i := 1 to 2 do begin
  110.                     if i = 1 then
  111.                         tmp := HighByte
  112.                     else
  113.                         tmp := LowByte;
  114.                     case tmp of
  115.                         0: 
  116.                             h := '0';
  117.                         1: 
  118.                             h := '1';
  119.                         2: 
  120.                             h := '2';
  121.                         3: 
  122.                             h := '3';
  123.                         4: 
  124.                             h := '4';
  125.                         5: 
  126.                             h := '5';
  127.                         6: 
  128.                             h := '6';
  129.                         7: 
  130.                             h := '7';
  131.                         8: 
  132.                             h := '8';
  133.                         9: 
  134.                             h := '9';
  135.                         10: 
  136.                             h := 'a';
  137.                         11: 
  138.                             h := 'b';
  139.                         12: 
  140.                             h := 'c';
  141.                         13: 
  142.                             h := 'd';
  143.                         14: 
  144.                             h := 'e';
  145.                         15: 
  146.                             h := 'f';
  147.                     end;
  148.                     hexbuf[HexCount] := h;
  149.                     HexCount := HexCount + 1;
  150.                     if HexCount mod 80 = 0 then begin
  151.                             HexBuf[HexCount] := cr;
  152.                             HexCount := HexCount + 1
  153.                         end;
  154.                 end;
  155.         end;
  156.  
  157.     begin
  158.         with info^ do begin
  159.                 if not IdentityFunction then
  160.                     GetLookupTable(table);
  161.                 MoveTo(-1, -1);
  162.                 LineTo(-1, -1); {Nothing prints without this dummy dot!}
  163.                 PicComment(PostScriptBegin, 0, nil); {See Tech Note #91}
  164.                 PicComment(TextIsPostScript, 0, nil);
  165.                 NumToString(HalftoneFrequency, freq);
  166.                 NumToString(HalftoneAngle, angle);
  167.                 if HalftoneDotFunction then
  168.                     DrawString(concat(freq, ' ', angle, ' {dup mul exch dup mul add 1 exch sub} setscreen'))
  169.                 else
  170.                     DrawString(concat(freq, ' ', angle, ' {pop} setscreen'));
  171.                 DrawString('0 0 translate');
  172.                 with RoiRect do begin
  173.                         iwidth := right - left;
  174.                         if iwidth > MaxLine then
  175.                             iwidth := MaxLine;
  176.                         iheight := bottom - top;
  177.                         hstart := left;
  178.                         vstart := top;
  179.                     end;
  180.                 NumToString(iwidth, width);
  181.                 NumToString(iheight, height);
  182.                 DrawString(concat(width, ' ', height, ' scale'));
  183.                 DrawString(concat('/PicStr ', width, ' string def'));
  184.                 DrawString(concat(width, ' ', height, ' 8 [', width, ' 0 0 ', height, ' 0 0]'));
  185.                 DrawString('{currentfile PicStr readhexstring pop} image');
  186.                 for vloc := vstart to vstart + iheight - 1 do begin
  187.                         GetLine(hstart, vloc, iwidth, aline);
  188.                         HexCount := 0;
  189.                         for hloc := 0 to iwidth - 1 do
  190.                             PutHex(aline[hloc]);
  191.                         HexBuf[HexCount] := cr;
  192.                         HexCount := HexCount + 1;
  193.                         err := PtrToHand(@HexBuf, HexBufH, HexCount);
  194.                         if err <> noErr then
  195.                             exit(PrintHalftone);
  196.                         PicComment(PostScriptHandle, HexCount, HexBufH);
  197.                         DisposHandle(HexBufH);
  198.                         Show2Values(vloc - vstart, iheight);
  199.                         if CommandPeriod then begin
  200.                                 beep;
  201.                                 eof := chr(4);
  202.                                 DrawString(eof);
  203.                                 exit(PrintHalftone)
  204.                             end;
  205.                     end;
  206.             end;
  207.     end;
  208.  
  209.  
  210.     procedure PrintTheImage (PageWidth, PageHeight: integer);
  211.         var
  212.             PrintRect: rect;
  213.             Width, Height: integer;
  214.  
  215.         procedure ScaleToFitPage;
  216.             var
  217.                 hscale, vscale, scale: real;
  218.         begin
  219.             hscale := PageWidth / width;
  220.             vscale := PageHeight / height;
  221.             if hscale <= vscale then
  222.                 scale := hscale
  223.             else
  224.                 scale := vscale;
  225.             width := trunc(scale * width);
  226.             height := trunc(scale * height);
  227.         end;
  228.  
  229.         procedure CenterOnPage;
  230.         begin
  231.             with PrintRect do begin
  232.                     left := 0;
  233.                     top := 0;
  234.                     if width < PageWidth then
  235.                         left := (PageWidth - width) div 2;
  236.                     if height < PageHeight then
  237.                         top := (Pageheight - height) div 2;
  238.                     right := left + width;
  239.                     bottom := top + height;
  240.                 end;
  241.         end;
  242.  
  243.     begin
  244.         if isLaserWriter and (not OptionKeyDown) and (not OptionKeyWasDown) and (not DriverHalftoning) then
  245.             PrintHalftone
  246.         else
  247.             with info^ do begin
  248.                     LoadLUT(cTable);
  249.                     hlock(handle(osPort^.portPixMap));
  250.                     with RoiRect do begin
  251.                             width := right - left;
  252.                             height := bottom - top;
  253.                         end;
  254.                     if (width > PageWidth) or (height > PageHeight) then
  255.                         ScaleToFitPage;
  256.                     CenterOnPage;
  257.                     if BitAnd(thePort^.portBits.rowBytes, $8000) = $8000 then begin
  258.                {Assume driver understands Color QD}
  259.                             hlock(handle(CGrafPort(ThePort^).PortPixMap));
  260.                             CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPort(ThePort^).PortPixMap)^^, RoiRect, PrintRect, SrcCopy, nil);
  261.                             hunlock(handle(CGrafPort(ThePort^).PortPixMap))
  262.                         end
  263.                     else
  264.                         CopyBits(BitMapHandle(osPort^.portPixMap)^^, thePort^.PortBits, RoiRect, PrintRect, SrcCopy, nil);
  265.                     hunlock(handle(osPort^.portPixMap));
  266.                 end;
  267.     end;
  268.  
  269.  
  270.     procedure PrintTextBuffer (PageHeight: integer; var PrintPort: TPPrPort);
  271.         const
  272.             LineInc = 13;
  273.         var
  274.             vloc, i, LineCount, CharCount, LinesPerPage, MaxCount: integer;
  275.             aLine: str255;
  276.     begin
  277.         ClipTextInBuffer := false;
  278.         LinesPerPage := PageHeight div LineInc;
  279.         vloc := LineInc;
  280.         LineCount := 0;
  281.         CharCount := 0;
  282.         TextFont(Monaco);
  283.         TextSize(9);
  284.         if WhatToPrint = PrintText then
  285.             MaxCount := 85
  286.         else
  287.             MaxCount := 255;
  288.         i := 1;
  289.         repeat
  290.             CharCount := 0;
  291.             while (TextBufP^[i] <> cr) and (CharCount < MaxCount) and (i <= TextBufSize) do begin
  292.                     CharCount := CharCount + 1;
  293.                     aLine[CharCount] := TextBufP^[i];
  294.                     i := i + 1;
  295.                 end;
  296.             if TextBufP^[i] = cr then
  297.                 i := i + 1
  298.             else if CharCount = MaxCount then begin
  299.                     while (aLine[CharCount] <> ' ') and (CharCount > (MaxCount - 15)) do begin
  300.                             CharCount := CharCount - 1;
  301.                             i := i - 1;
  302.                         end;
  303.                     if TextBufP^[i] = ' ' then
  304.                         i := i + 1;
  305.                 end;
  306.             aLine[0] := chr(CharCount);
  307.             MoveTo(0, vloc);
  308.             DrawString(aLine);
  309.             vLoc := vLoc + LineInc;
  310.             LineCount := LineCount + 1;
  311.             if LineCount >= LinesPerPage then begin
  312.                     LineCount := 0;
  313.                     if i < TextBufSize then begin
  314.                             PrClosePage(PrintPort);
  315.                             PrintErrCheck;
  316.                             PrOpenPage(PrintPort, nil);
  317.                             vloc := LineInc
  318.                         end;
  319.                 end;
  320.         until i > TextBufSize;
  321.     end;
  322.  
  323.  
  324.     procedure DoPrintText (PageHeight: integer; var PrintPort: TPPrPort);
  325.         var
  326.             ByteCount: LongInt;
  327.     begin
  328.         if TextInfo <> nil then
  329.             with TextInfo^.TextTE^^ do begin
  330.                     ByteCount := TELength;
  331.                     BlockMove(hText^, ptr(TextBufP), ByteCount);
  332.                     TextBufSize := ByteCount;
  333.                     PrintTextBuffer(PageHeight, PrintPort);
  334.                 end;
  335.     end;
  336.  
  337.  
  338.     procedure Print (ShowDialog: boolean);
  339.         var
  340.             err, i, LinesToPrint: Integer;
  341.             tPort: GrafPtr;
  342.             PrintPort: TPPrPort;
  343.             PrintStatusRec: TPrStatus;
  344.             prect: rect;
  345.             result: boolean;
  346.     begin
  347.         if WhatToPrint = PrintImage then
  348.             SelectAll(false);
  349.         if (WhatToPrint = PrintImage) or (WhatToPrint = PrintSelection) then begin
  350.                 if OpPending then
  351.                     KillRoi;
  352.                 with info^.RoiRect do
  353.                     LinesToPrint := bottom - top;
  354.                 if not DriverHalftoning then begin
  355.                         DrawLabels('Line:', 'Total:', '');
  356.                         Show2Values(0, LinesToPrint);
  357.                     end;
  358.             end;
  359.         GetPort(tPort);
  360.         PrOpen;
  361.         if PrintRecord = nil then begin
  362.                 PrintRecord := THPrint(NewHandle(SizeOF(TPrint)));
  363.                 PrintDefault(PrintRecord);
  364.             end;
  365.         if PrError = NoErr then begin
  366.                 InitCursor;
  367.                 result := PrValidate(PrintRecord);
  368.                 isLaserWriter := BSR(PrintRecord^^.prStl.wDev, 8) = 3;
  369.                 prect := PrintRecord^^.prInfo.rPage;
  370.                 if ShowDialog then
  371.                     result := PrJobDialog(PrintRecord)
  372.                 else
  373.                     result := true;
  374.                 if not DriverHalftoning then
  375.                     ShowMessage(CmdPeriodToStop);
  376.                 ShowWatch;
  377.                 if result then
  378.                     for i := 1 to PrintRecord^^.PrJob.icopies do begin
  379.                             PrintPort := PrOpenDoc(PrintRecord, nil, nil);
  380.                             PrintErrCheck;
  381.                             Printing := true;
  382.                             PrOpenPage(PrintPort, nil);
  383.                             if PrError = NoErr then
  384.                                 case WhatToPrint of
  385.                                     PrintImage, PrintSelection: 
  386.                                         PrintTheImage(prect.right, prect.bottom);
  387.                                     PrintMeasurements:  begin
  388.                                             CopyResultsToBuffer(1, mCount, true);
  389.                                             PrintTextBuffer(prect.Bottom, PrintPort);
  390.                                             UnsavedResults := false;
  391.                                         end;
  392.                                     PrintPlot: 
  393.                                         DrawPlot;
  394.                                     PrintHistogram: 
  395.                                         DrawHistogram;
  396.                                     PrintText: 
  397.                                         DoPrintText(prect.Bottom, PrintPort);
  398.                                 end;
  399.                             Printing := false;
  400.                             PrClosePage(PrintPort);
  401.                             PrintErrCheck;
  402.                             PrCloseDoc(PrintPort);
  403.                             PrintErrCheck;
  404.                             if PrintRecord^^.prJob.bJDocLoop = bSpoolLoop then
  405.                                 PrPicFile(PrintRecord, nil, nil, nil, PrintStatusRec);
  406.                         end;
  407.             end;
  408.         PrClose;
  409.         SetPort(tPort);
  410.         if WhatToPrint = PrintImage then
  411.             KillRoi;
  412.         ShowMessage(' ');
  413.     end;
  414.  
  415.  
  416.     procedure SetHalftone;
  417.         const
  418.             FrequencyID = 8;
  419.             AngleID = 10;
  420.             DotID = 4;
  421.             LineID = 5;
  422.         var
  423.             mylog: DialogPtr;
  424.             item, i, ignore, SaveFrequency, SaveAngle: integer;
  425.             SaveFunction: boolean;
  426.             str: str255;
  427.     begin
  428.         if DriverHalftoning then begin
  429.                 PutMessage('Custom halftoning is only available when Custom Grayscale Halftoning is checked in the Preferences dialog box.');
  430.                 exit(SetHalftone);
  431.             end;
  432.         SaveFrequency := HalftoneFrequency;
  433.         SaveAngle := HalftoneAngle;
  434.         SaveFunction := HalftoneDotFunction;
  435.         mylog := GetNewDialog(30, nil, pointer(-1));
  436.         SetDNum(MyLog, FrequencyID, HalftoneFrequency);
  437.         SelIText(MyLog, FrequencyID, 0, 32767);
  438.         SetDNum(MyLog, AngleID, HalftoneAngle);
  439.         OutlineButton(MyLog, ok, 16);
  440.         if HalftoneDotFunction then
  441.             SetDialogItem(mylog, DotID, 1)
  442.         else
  443.             SetDialogItem(mylog, LineID, 1);
  444.         repeat
  445.             ModalDialog(nil, item);
  446.             if item = FrequencyID then
  447.                 HalftoneFrequency := GetDNum(MyLog, FrequencyID);
  448.             if item = AngleID then begin
  449.                     HalftoneAngle := GetDNum(MyLog, AngleID);
  450.                     if (HalftoneAngle < 0) or (HalftoneAngle > 180) then begin
  451.                             beep;
  452.                             HalftoneAngle := SaveAngle;
  453.                         end;
  454.                 end;
  455.             if (item >= DotID) and (item <= LineID) then begin
  456.                     for i := DotID to LineID do
  457.                         SetDialogItem(mylog, i, 0);
  458.                     SetDialogItem(mylog, item, 1);
  459.                     HalftoneDotFunction := item = DotID;
  460.                 end;
  461.         until (item = ok) or (item = cancel);
  462.         DisposDialog(mylog);
  463.         if item = cancel then begin
  464.                 HalftoneFrequency := SaveFrequency;
  465.                 HalftoneAngle := SaveAngle;
  466.                 HalftoneDotFunction := SaveFunction;
  467.             end;
  468.     end;
  469.  
  470.  
  471. {$POP}
  472.  
  473.     procedure GetFileInfo (name: str255; vnum: integer; var DateCreated, LastModified: str255);
  474.         var
  475.             FileParmBlock: ParmBlkPtr;
  476.             theErr: OSErr;
  477.             DateVar, TimeVar: str255;
  478.             Secs: LongInt;
  479.     begin
  480.         DateCreated := '';
  481.         new(FIleParmBlock);
  482.         if FileParmBlock <> nil then
  483.             with FileParmBlock^ do begin
  484.                     ioCompletion := nil;
  485.                     ioNamePtr := @name;
  486.                     ioVRefNum := vnum;
  487.                     ioFVersNum := 0;
  488.                     ioFDirIndex := 0;
  489.                     theErr := PBGetFInfo(FileParmBlock, false);
  490.                     if theErr = NoErr then begin
  491.                             Secs := ioFlCrDat;
  492.                             IUDateString(Secs, abbrevDate, DateVar);
  493.                             IUTimeString(Secs, true, TimeVar);
  494.                             DateCreated := concat(DateVar, '  ', TimeVar);
  495.                             Secs := ioFlMDDat;
  496.                             IUDateString(Secs, abbrevDate, DateVar);
  497.                             IUTimeString(Secs, true, TimeVar);
  498.                             LastModified := concat(DateVar, '  ', TimeVar);
  499.                         end;
  500.                     Dispose(FileParmBlock);
  501.                 end;
  502.     end;
  503.  
  504.  
  505.     procedure GetVolumnInfo (vnum: integer; var VolumnName: str255; var FreeSpace: LongInt);
  506.         var
  507.             theErr: OSErr;
  508.             SPtr: StringPtr;
  509.             VolParmBlock: ParmBlkPtr;
  510.     begin
  511.         VolumnName := '';
  512.         new(SPtr);
  513.         new(VolParmBlock);
  514.         if (SPtr <> nil) and (VolParmBlock <> nil) then
  515.             with VolParmBlock^ do begin
  516.                     SPtr^ := '';
  517.                     ioVRefNum := vnum;
  518.                     ioNamePtr := SPtr;
  519.                     ioCompletion := nil;
  520.                     ioVolIndex := -1;
  521.                     theErr := PBGetVInfo(VolParmBlock, false);
  522.                     VolumnName := ioNamePtr^;
  523.                     FreeSpace := ioVAlBlkSiz * ioVFrBlk;
  524.                     dispose(SPtr);
  525.                     dispose(VolParmBlock);
  526.                 end;
  527.     end;
  528.  
  529.  
  530.     function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean;
  531.         var
  532.             err: OSErr;
  533.             f: integer;
  534.             VolumnName: str255;
  535.             FreeSpace, ExistingFileSize, NeededSize: LongInt;
  536.     begin
  537.         with info^ do begin
  538.                 ExistingFileSize := 0;
  539.                 RoomForFile := true;
  540.                 err := fsopen(fname, RefNum, f);
  541.                 if err = 0 then begin
  542.                         err := GetEOF(f, ExistingFileSize);
  543.                         err := fsClose(f);
  544.                     end;
  545.                 if ExistingFileSize <> 0 then begin
  546.                         if SavingSelection then
  547.                             NeededSize := LongInt(slines) * sPixelsPerLine
  548.                         else
  549.                             NeededSize := ImageSize;
  550.                         if StackInfo <> nil then
  551.                             with StackInfo^ do
  552.                                 NeededSize := NeededSize * nSlices + nSlices * SizeOf(StackIFDType);
  553.                         GetVolumnInfo(RefNum, VolumnName, FreeSpace);
  554.                         if (NeededSize - ExistingFileSize + 8192) > FreeSpace then begin
  555.                                 PutMessage('There is not enough free space on this disk to save this image.');
  556.                                 RoomForFile := false;
  557.                             end;
  558.                     end;
  559.             end;
  560.     end;
  561.  
  562.  
  563.     procedure GetInfo;
  564.         var
  565.             name, str, DateCreated, LastModified, VolumnName, str2: str255;
  566.             hloc, vloc, InfoWidth, InfoHeight: integer;
  567.             SaveRoiShowing: boolean;
  568.             FreeSpace, DataSize: LongInt;
  569.             SaveForeIndex, SaveBackIndex: integer;
  570.             ImageInfo, InfoWindowInfo: InfoPtr;
  571.             x1, y1, x2, y2, ulength, clength: real;
  572.  
  573.         procedure NewLine;
  574.         begin
  575.             vloc := vloc + 13;
  576.             MoveTo(hloc, vloc);
  577.         end;
  578.  
  579.         procedure NewParagraph;
  580.         begin
  581.             vloc := vloc + 18;
  582.             MoveTo(hloc, vloc);
  583.         end;
  584.  
  585.     begin
  586.         InfoWidth := 260;
  587.         InfoHeight := 260;
  588.         with info^ do begin
  589.                 if RoiShowing then
  590.                     InfoHeight := InfoHeight + 50;
  591.                 if RoiShowing and (RoiType = LineRoi) then
  592.                     InfoHeight := InfoHeight + 20;
  593.                 if vref <> 0 then
  594.                     InfoHeight := InfoHeight + 60;
  595.                 name := concat('Info About ', title);
  596.                 SaveRoiShowing := RoiShowing;
  597.             end;
  598.         SaveForeIndex := ForegroundIndex;
  599.         SaveBackIndex := BackgroundIndex;
  600.         SetForegroundColor(BlackIndex);
  601.         SetBackgroundColor(WhiteIndex);
  602.         ImageInfo := info;
  603.         if NewPicWindow(name, InfoWidth, InfoHeight) then
  604.             with ImageInfo^ do begin
  605.                     InfoWindowInfo := Info;
  606.                     SetPort(GrafPtr(info^.osPort));
  607.                     TextFont(ApplFont);
  608.                     TextSize(9);
  609.                     hloc := 15;
  610.                     vloc := 10;
  611.                     NewLine;
  612.                     DrawBString('Name: ');
  613.                     DrawString(title);
  614.                     NewParagraph;
  615.                     DrawBString('Width: ');
  616.                     DrawXDimension(PixelsPerLine, 0);
  617.                     NewLine;
  618.                     DrawBString('Height: ');
  619.                     DrawYDimension(nlines, 0);
  620.                     if StackInfo <> nil then begin
  621.                             NewLine;
  622.                             DrawBString('Depth: ');
  623.                             DrawLong(StackInfo^.nSlices);
  624.                         end;
  625.                     NewLine;
  626.                     DrawBString('Size: ');
  627.                     if StackInfo <> nil then
  628.                         DataSize := PixMapSize * StackInfo^.nSlices
  629.                     else
  630.                         DataSize := PixMapSize;
  631.                     DrawLong((DataSize + 511) div 1024);
  632.                     DrawString('K');
  633.                     NewParagraph;
  634.                     GetFileInfo(title, vref, DateCreated, LastModified); {DateCreated:='';}
  635.                     if DateCreated <> '' then begin
  636.                             DrawBString('Creation Date: ');
  637.                             DrawString(DateCreated);
  638.                             NewLine;
  639.                             DrawBString('Last Modified: ');
  640.                             DrawString(LastModified);
  641.                             NewLine;
  642.                         end;
  643.                     if iVersion > 0 then begin
  644.                             DrawBString('Version: ');
  645.                             DrawString('Created by Image ');
  646.                             DrawReal(iVersion / 100.0, 1, 2);
  647.                             NewLine;
  648.                         end;
  649.                     if vref <> 0 then begin
  650.                             GetVolumnInfo(vref, VolumnName, FreeSpace);
  651.                             if VolumnName <> '' then begin
  652.                                     DrawBString('Volume: ');
  653.                                     DrawString(VolumnName);
  654.                                     DrawString(' (');
  655.                                     DrawLong(FreeSpace div 1024);
  656.                                     DrawString('K free)');
  657.                                     NewParagraph;
  658.                                 end;
  659.                         end;
  660.                     DrawBString('Type: ');
  661.                     if StackInfo <> nil then
  662.                         str := concat('Stack (', long2str(StackInfo^.nSlices), '  slices)')
  663.                     else begin
  664.                             case PictureType of
  665.                                 pdp11: 
  666.                                     str := 'PDP-11';
  667.                                 NewPicture: 
  668.                                     str := 'New';
  669.                                 normal: 
  670.                                     str := 'Normal';
  671.                                 PictFile: 
  672.                                     str := 'PICT';
  673.                                 TiffFile, InvertedTIFF: 
  674.                                     str := 'TIFF';
  675.                                 Leftover: 
  676.                                     str := 'Left Over';
  677.                                 imported:  begin
  678.                                         if DataType = EightBits then
  679.                                             str := 'Imported 8-bit image'
  680.                                         else
  681.                                             str := 'Imported 16-bit image';
  682.                                     end;
  683.                                 FrameGrabberType: 
  684.                                     str := 'Camera';
  685.                                 BlankField: 
  686.                                     str := 'Blank Field';
  687.                                 ScionType: 
  688.                                     str := 'Camera(Scion)';
  689.                                 otherwise
  690.                                     ;
  691.                             end;
  692.                             if BinaryPic then
  693.                                 str := concat(str, ' (Binary)');
  694.                         end;
  695.                     DrawString(str);
  696.                     if StackInfo <> nil then
  697.                         with StackInfo^ do
  698.                             if SliceSpacing <> 0.0 then begin
  699.                                     NewLine;
  700.                                     DrawBString('Slice Spacing: ');
  701.                                     RealToString(SliceSpacing, 1, 1, str);
  702.                                     DrawString(str);
  703.                                     DrawString(' pixels');
  704.                                 end;
  705.                     NewLine;
  706.                     DrawBString('Lookup Table: ');
  707.                     case LutMode of
  708.                         PseudoColor: 
  709.                             str := concat('Pseudocolor(', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')');
  710.                         GrayScale: 
  711.                             str := concat('Grayscale(', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')');
  712.                         ColorLut: 
  713.                             str := 'Color';
  714.                         CustomGrayscale: 
  715.                             str := 'Custom Grayscale';
  716.                         otherwise
  717.                     end;
  718.                     DrawString(str);
  719.                     NewLine;
  720.                     DrawBString('Magnification: ');
  721.                     if ScaleToFitWindow then begin
  722.                             DrawReal(magnification, 1, 2);
  723.                             DrawString(' (Scale to Window Mode)')
  724.                         end
  725.                     else begin
  726.                             DrawReal(magnification, 1, 0);
  727.                             DrawString(':1')
  728.                         end;
  729.                     NewLine;
  730.                     DrawBString('Scale: ');
  731.                     if SpatiallyCalibrated then begin
  732.                             DrawReal(xSpatialScale, 1, 3);
  733.                             DrawString(' pixels per ');
  734.                             DrawString(xUnit);
  735.                             if PixelAspectRatio <> 1.0 then begin
  736.                                     NewLine;
  737.                                     DrawBString('Pixel Aspect Ratio: ');
  738.                                     DrawReal(PixelAspectRatio, 1, 4);
  739.                                 end;
  740.                         end
  741.                     else
  742.                         DrawString('None');
  743.                     if DensityCalibrated then begin
  744.                             NewLine;
  745.                             DrawBString('Unit of Measure: ');
  746.                             if UnitOfMEasure = '' then
  747.                                 DrawString('None')
  748.                             else
  749.                                 DrawString(UnitOfMeasure)
  750.                         end;
  751.                     NewParagraph;
  752.                     DrawBString('Free RAM: ');
  753.                     DrawLong(FreeMem div 1024);
  754.                     DrawString('K');
  755.                     NewLine;
  756.                     DrawBString('Largest Free Block: ');
  757.                     DrawLong(MaxBlock div 1024);
  758.                     DrawString('K');
  759.                     if FrameGrabber <> NoFrameGrabber then begin
  760.                             NewLine;
  761.                             DrawBString('Frame Grabber: ');
  762.                             case FrameGrabber of
  763.                                 QuickCapture:  begin
  764.                                         if fgWidth = 768 then
  765.                                             DrawString('50Hz')
  766.                                         else
  767.                                             DrawString('60Hz');
  768.                                         DrawString(' Data Translation QuickCapture');
  769.                                     end;
  770.                                 ScionLG3:  begin
  771.                                         if fgWidth = 768 then
  772.                                             DrawString('50Hz')
  773.                                         else
  774.                                             DrawString('60Hz');
  775.                                         DrawString(' SCION LG-3(');
  776.                                         DrawLong(MaxLG3Frames div 2);
  777.                                         DrawString(' MB)');
  778.                                     end
  779.                             end;
  780.                         end;
  781.                     NewParagraph;
  782.                     if RoiType <> NoRoi then begin
  783.                             DrawBString('Selection Type: ');
  784.                             case RoiType of
  785.                                 PolygonRoi: 
  786.                                     DrawString('Polygon');
  787.                                 FreehandRoi: 
  788.                                     DrawString('Freehand');
  789.                                 RectRoi: 
  790.                                     DrawString('Rectangle');
  791.                                 OvalRoi: 
  792.                                     DrawString('Oval');
  793.                                 LineRoi: 
  794.                                     DrawString('Straight Line');
  795.                                 FreeLineRoi: 
  796.                                     DrawString('Freehand Line');
  797.                                 SegLineRoi: 
  798.                                     DrawString('Segmented Line');
  799.                             end;
  800.                             NewLine;
  801.                             case RoiType of
  802.                                 PolygonRoi, FreehandRoi, RectRoi, OvalRoi: 
  803.                                     with RoiRect do begin
  804.                                             DrawBString('    Left: ');
  805.                                             DrawXDimension(left, 0);
  806.                                             NewLine;
  807.                                             DrawBString('    Top: ');
  808.                                             if InvertYCoordinates then
  809.                                                 DrawYDimension(PicRect.bottom - top - 1, 0)
  810.                                             else
  811.                                                 DrawYDimension(top, 0);
  812.                                             NewLine;
  813.                                             DrawBString('    Width: ');
  814.                                             DrawXDimension(right - left, 0);
  815.                                             NewLine;
  816.                                             DrawBString('    Height: ');
  817.                                             DrawYDimension(bottom - top, 0);
  818.                                         end;
  819.                                 LineRoi:  begin
  820.                                         info := ImageInfo;
  821.                                         GetLengthOrPerimeter(ulength, clength);
  822.                                         GetLoi(x1, y1, x2, y2);
  823.                                         Info := InfoWindowInfo;
  824.                                         DrawBString('    Length: ');
  825.                                         if SpatiallyCalibrated then begin
  826.                                                 DrawReal(cLength, 1, 2);
  827.                                                 DrawString(xUnit);
  828.                                             end
  829.                                         else
  830.                                             DrawReal(uLength, 1, 2);
  831.                                         NewLine;
  832.                                         DrawBString('    Angle: ');
  833.                                         DrawReal(LAngle, 1, 2);
  834.                                         DrawString('í');
  835.                                         NewLine;
  836.                                         DrawBString('    X1: ');
  837.                                         DrawXDimension(x1, 2);
  838.                                         NewLine;
  839.                                         DrawBString('    Y1: ');
  840.                                         if InvertYCoordinates then
  841.                                             DrawYDimension(PicRect.bottom - y1 - 1, 2)
  842.                                         else
  843.                                             DrawYDimension(y1, 2);
  844.                                         NewLine;
  845.                                         DrawBString('    X2: ');
  846.                                         DrawXDimension(x2, 2);
  847.                                         NewLine;
  848.                                         DrawBString('    Y2: ');
  849.                                         if InvertYCoordinates then
  850.                                             DrawYDimension(PicRect.bottom - y2 - 1, 2)
  851.                                         else
  852.                                             DrawYDimension(y2, 2);
  853.                                     end;
  854.                                 FreeLineRoi, SegLineRoi:  begin
  855.                                         info := ImageInfo;
  856.                                         GetLengthOrPerimeter(ulength, clength);
  857.                                         Info := InfoWindowInfo;
  858.                                         DrawBString('    Length: ');
  859.                                         if SpatiallyCalibrated then begin
  860.                                                 DrawReal(cLength, 1, 2);
  861.                                                 DrawString(xUnit);
  862.                                             end
  863.                                         else
  864.                                             DrawReal(uLength, 1, 2);
  865.                                         NewLine;
  866.                                     end;
  867.                                 otherwise
  868.                             end; {case}
  869.                         end
  870.                     else
  871.                         DrawBString('No Selection');
  872.                 end;
  873.         SetForegroundColor(SaveForeIndex);
  874.         SetBackgroundColor(SaveBackIndex);
  875.     end;
  876.  
  877.  
  878.     function NewPtrClear (blockSize: Size): Ptr;
  879.     {This function will return a pointer of size specified and will}
  880.     {clear the memory to zeros . This is done to create an empty bit}
  881.     {map containing nothing but white bits . }
  882.  
  883.     {MOVE . L  ( SP ) + , D0  ; get Size variable from stack}
  884.     {_NewPtr , clear           ; make pointer }
  885.     {MOVE.L  A0 , ( SP )       ; return pointer }
  886.     {MOVE.W D0, MemErr     ; set up MemErr }
  887.     inline
  888.         $201F, $A31E, $2E88, $31C0, $0220;
  889.  
  890.  
  891.     function CheckIO (err: OSerr): integer;
  892.         var
  893.             ErrStr, Message: str255;
  894.             ignore: integer;
  895.     begin
  896.         if err <> 0 then begin
  897.                 Message := '';
  898.                 case err of
  899.                     -34: 
  900.                         Message := 'Disk Full';
  901.                     -36: 
  902.                         Message := 'I/O Error';
  903.                     -49: 
  904.                         Message := 'File in Use';
  905.                     -61: 
  906.                         Message := 'Write Permission Error';
  907.                 end;
  908.                 NumToString(err, ErrStr);
  909.                 ParamText(Message, ErrStr, '', '');
  910.                 InitCursor;
  911.                 ignore := alert(IOErrorID, nil);
  912.                 macro := false; {If macro, abort it}
  913.             end;
  914.         CheckIO := err;
  915.     end;
  916.  
  917.  
  918.     function OpenMacPaint (fname: str255; vnum: integer): boolean;
  919.         const
  920.             MaxUnPackedSize = 51840;   {Max MacPaint size in bytes=720 lines * 72 bytes/line }
  921.         type
  922.             mpLine = array[1..18] of LongInt;
  923.             mpArrayT = array[1..720] of mpLine;
  924.             mpArrayP = ^mpArrayT;
  925.         var
  926.             i, f, ScanLine, LastLine, LastWord, LastColumn: integer;
  927.             err: osErr;
  928.             srcSize: LongInt;
  929.             srcPtr, dstPtr, src, dst: ptr;
  930.             theBitMap: BitMap;
  931.             mpArray: mpArrayP;
  932.             BlankLine, BlankColumn: boolean;
  933.             frect: rect;
  934.  
  935.         procedure abort;
  936.         begin
  937.             beep;
  938.             if srcPtr <> nil then
  939.                 DisposPtr(srcPtr);
  940.             if dstPtr <> nil then
  941.                 DisposPtr(dstPtr);
  942.             exit(OpenMacPaint);
  943.         end;
  944.  
  945.     begin
  946.         OpenMacPaint := false;
  947.         err := fsOpen(fname, vnum, f);
  948.         if CheckIO(err) <> noErr then
  949.             exit(OpenMacPaint);
  950.         err := GetEOF(f, srcSize);
  951.         srcSize := srcSize - 512;
  952.         srcPtr := NewPtr(srcSize);
  953.         if srcPtr = nil then
  954.             abort;
  955.         err := SetFPos(f, fsFromStart, 512);
  956.         err := fsRead(f, srcSize, srcPtr);
  957.         if CheckIO(err) <> noErr then
  958.             exit(OpenMacPaint);
  959.         err := fsClose(f);
  960.         dstPtr := NewPtrClear(MaxUnPackedSize);
  961.         if dstPtr = nil then
  962.             abort;
  963.         src := srcPtr;
  964.         dst := dstPtr;
  965.         for scanLine := 1 to 720 do
  966.             UnPackBits(src, dst, 72); {bumps both ptrs}
  967.         DisposPtr(srcPtr);
  968.         mpArray := mpArrayP(dstPtr);
  969.         LastLine := 720;
  970.         BlankLine := true;
  971.         repeat
  972.             for i := 1 to 18 do
  973.                 blankLine := BlankLine and (mpArray^[LastLine, i] = 0);
  974.             if BlankLine then
  975.                 LastLine := LastLine - 1;
  976.         until (not BlankLine) or (LastLine = 1);
  977.         LastWord := 18;
  978.         BlankColumn := true;
  979.         repeat
  980.             for i := 1 to LastLine do
  981.                 blankColumn := BlankColumn and (mpArray^[i, LastWord] = 0);
  982.             if BlankColumn then
  983.                 LastWord := LastWord - 1;
  984.         until (not BlankColumn) or (LastWord = 1);
  985.         LastColumn := LastWord * 32;
  986.         LastColumn := LastColumn + 8;
  987.         if LastColumn > 576 then
  988.             LastColumn := 576;
  989.         LastLine := LastLine + 8;
  990.         if LastLine > 720 then
  991.             LastLine := 720;
  992.         SetRect(frect, 0, 0, LastColumn, LastLine);
  993.         with theBitMap do begin
  994.                 baseAddr := dstPtr;
  995.                 rowBytes := 72;
  996.                 bounds := frect;
  997.             end;
  998.         if not NewPicWindow(fname, LastColumn, LastLine) then
  999.             abort;
  1000.         SetForegroundColor(BlackIndex);
  1001.         SetBackgroundColor(WhiteIndex);
  1002.         with info^ do begin
  1003.                 hlock(handle(osPort^.portPixMap));
  1004.                 CopyBits(theBitMap, BitMapHandle(osPort^.PortPixMap)^^, frect, frect, srcCopy, nil);
  1005.                 hunlock(handle(osPort^.PortPixMap));
  1006.                 DisposPtr(dstPtr);
  1007.                 PictureType := imported;
  1008.                 BinaryPic := true;
  1009.                 if PixMapSize > UndoBufSize then
  1010.                     PutWarning;
  1011.             end;
  1012.         OpenMacPaint := true;
  1013.     end;
  1014.  
  1015.  
  1016.     procedure TypeMismatch (fname: str255);
  1017.     begin
  1018.         PutMessage(concat('The file "', fname, '" is a different type, and therefore cannot be replaced'));
  1019.     end;
  1020.  
  1021.  
  1022.     procedure SaveAsMacPaint (fname: str255; RefNum: integer);
  1023.         const
  1024.             MaxFileSize = 53072;   { maximum MacPaint file size. }
  1025.         var
  1026.             TheInfo: FInfo;
  1027.             dstPtr, srcPtr, mpBufPtr: Ptr;
  1028.             i, f, scanLine, err, width, height: integer;
  1029.             dstBuffer: array[1..128] of LongInt;
  1030.             size, dstSize: LongInt;
  1031.             theBitMap: BitMap;
  1032.             mprect, srect, drect: rect;
  1033.  
  1034.         procedure abort;
  1035.         begin
  1036.             beep;
  1037.             if mpBufPtr <> nil then
  1038.                 DisposPtr(mpBufPtr);
  1039.             if f <> -1 then
  1040.                 err := fsclose(f);
  1041.             exit(SaveAsMacPaint);
  1042.         end;
  1043.  
  1044.     begin
  1045.         f := -1;
  1046.         err := GetFInfo(fname, RefNum, TheInfo);
  1047.         case err of
  1048.             NoErr: 
  1049.                 with TheInfo do begin
  1050.                         if fdType <> 'PNTG' then begin
  1051.                                 TypeMismatch(fname);
  1052.                                 exit(SaveAsMacPaint)
  1053.                             end;
  1054.                     end;
  1055.             FNFerr:  begin
  1056.                     err := create(fname, RefNum, 'MPNT', 'PNTG');
  1057.                     if CheckIO(err) <> 0 then
  1058.                         exit(SaveAsMacPaint);
  1059.                 end;
  1060.             otherwise
  1061.                 if CheckIO(err) <> 0 then
  1062.                     exit(SaveAsMacPaint);
  1063.         end;
  1064.         mpBufPtr := NewPtrClear(MaxFileSize);
  1065.         if mpBufPtr = nil then
  1066.             abort;
  1067.         ShowWatch;
  1068.         SetRect(mprect, 0, 0, 576, 720);
  1069.         with theBitMap do begin
  1070.                 baseAddr := mpBufPtr;
  1071.                 rowBytes := 72;
  1072.                 bounds := mprect;
  1073.             end;
  1074.         with info^ do begin
  1075.                 if roiShowing then
  1076.                     srect := RoiRect
  1077.                 else
  1078.                     srect := PicRect;
  1079.                 with srect do begin
  1080.                         width := right - left;
  1081.                         height := bottom - top;
  1082.                         if width > 576 then
  1083.                             width := 576;
  1084.                         if height > 720 then
  1085.                             height := 720;
  1086.                         right := left + width;
  1087.                         bottom := top + height;
  1088.                     end;
  1089.                 SetRect(drect, 0, 0, width, height);
  1090.                 hlock(handle(osPort^.portPixMap));
  1091.                 CopyBits(BitMapHandle(osPort^.PortPixMap)^^, theBitMap, srect, drect, srcCopy, nil);
  1092.                 hunlock(handle(osPort^.PortPixMap));
  1093.             end;
  1094.         err := fsOpen(fname, RefNum, f);
  1095.         if CheckIO(err) <> noErr then
  1096.             abort;
  1097.         for I := 1 to 128 do
  1098.             dstBuffer[I] := 0;
  1099.         Size := 512;
  1100.         err := FSWrite(f, Size, @dstBuffer);
  1101.         if CheckIO(err) <> noErr then
  1102.             abort;
  1103.         srcPtr := theBitMap.baseAddr;
  1104.         for scanLine := 1 to 720 do begin
  1105.                 dstPtr := @dstBuffer; { reset the pointer to bottom }
  1106.                 PackBits(srcPtr, dstPtr, 72); { bumps both ptrs}
  1107.                 dstSize := ord(dstPtr) - ord(@dstBuffer);{calc packed size}
  1108.                 err := fsWrite(f, dstSize, @dstBuffer);
  1109.                 if CheckIO(err) <> noErr then
  1110.                     abort;
  1111.             end;
  1112.         err := fsclose(f);
  1113.         DisposPtr(mpBufPtr);
  1114.         info^.changes := false;
  1115.     end;
  1116.  
  1117.  
  1118.     function GetTextFile (var name: str255; var RefNum: integer): boolean;
  1119.         var
  1120.             where: Point;
  1121.             typeList: SFTypeList;
  1122.             reply: SFReply;
  1123.             err: OSErr;
  1124.             pBlock: WDPBRec;
  1125.     begin
  1126.         where.v := 120;
  1127.         where.h := 120;
  1128.         typeList[0] := 'TEXT';
  1129.         SFGetFile(Where, '', nil, 1, typeList, nil, reply);
  1130.         if reply.good then
  1131.             with reply do begin
  1132.                     name := fname;
  1133.                     RefNum := vRefNum;
  1134.                     GetTextFile := true;
  1135.                 end
  1136.         else
  1137.             GetTextFile := false;
  1138.     end;
  1139.  
  1140.  
  1141.     procedure GetBuffer;
  1142.         var
  1143.             err: OSErr;
  1144.             count, FilePos: LongInt;
  1145.     begin
  1146.         count := MaxTextBufSize;
  1147.         err := fsread(Textf, count, ptr(TextBufP));
  1148.         TextBufSize := count;
  1149.         err := GetFPos(Textf, FilePos);
  1150.         if FilePos = TextFileSize then begin
  1151.                 TextBufSize := TextBufSize + 1;
  1152.                 if TextBufSize > MaxTextBufSize then
  1153.                     TextBufSize := MaxTextBufSize;
  1154.                 TextBufP^[TextBufSize] := eof;
  1155.                 err := fsclose(Textf);
  1156.             end;
  1157.         TextIndex := 1;
  1158.     end;
  1159.  
  1160.  
  1161.     function GetByte: char;
  1162.     begin
  1163.         GetByte := TextBufP^[TextIndex];
  1164.         TextIndex := TextIndex + 1;
  1165.         if TextIndex > MaxTextBufSize then
  1166.             GetBuffer;
  1167.     end;
  1168.  
  1169.  
  1170.     function GetNumber: real;
  1171.         var
  1172.             c: char;
  1173.             str: str255;
  1174.     begin
  1175.         repeat
  1176.             c := GetByte;
  1177.             if c = tab then begin
  1178.                     GetNumber := 0.0;
  1179.                     exit(GetNumber);
  1180.                 end;
  1181.             if (c = cr) or (c = eof) then begin
  1182.                     TextEol := true;
  1183.                     TextEof := c = eof;
  1184.                     GetNumber := NoValue;
  1185.                     exit(GetNumber);
  1186.                 end;
  1187.         until c in ['0'..'9', '-', '.'];
  1188.         Str := '';
  1189.         while c in ['0'..'9', '+', '-', '.', 'e', 'E'] do begin
  1190.                 Str := concat(str, c);
  1191.                 c := GetByte;
  1192.                 if (c = cr) or (c = eof) then begin
  1193.                         TextEol := true;
  1194.                         TextEof := c = eof;
  1195.                     end;
  1196.             end;
  1197.         GetNumber := StringToReal(str);
  1198.     end;
  1199.  
  1200.  
  1201.     procedure GetLineFromText (var rLine: RealLine; var count: integer);
  1202.         var
  1203.             n: real;
  1204.     begin
  1205.         count := 0;
  1206.         if TextEof then
  1207.             exit(GetLineFromText);
  1208.         repeat
  1209.             n := GetNumber;
  1210.             if n <> NoValue then begin
  1211.                     count := count + 1;
  1212.                     rLine[count] := n;
  1213.                 end;
  1214.         until TextEol or (count = MaxLine);
  1215.         TextEol := false;
  1216.     end;
  1217.  
  1218.  
  1219.     procedure InitTextInput (name: str255; RefNum: integer);
  1220.         var
  1221.             err: OSErr;
  1222.     begin
  1223.         err := FSOpen(name, RefNum, Textf);
  1224.         err := GetEof(Textf, TextFileSize);
  1225.         err := SetFPos(Textf, fsFromStart, 0);
  1226.         ShowWatch;
  1227.         if WhatsOnClip = TextOnClip then
  1228.             WhatsOnClip := NothingOnClip;
  1229.         GetBuffer;
  1230.         TextEol := false;
  1231.         TextEof := false;
  1232.     end;
  1233.  
  1234.  
  1235.     function ImportTextFile (name: str255; RefNum: integer): boolean;
  1236.         var
  1237.             nRows, nColumns, count, i, vloc, BlankPixel, nPixelsPerLine: integer;
  1238.             rLine: RealLine;
  1239.             pvalue: real;
  1240.             min, max, ScaleFactor, DefaultValue, tvalue: extended;
  1241.             err: OSErr;
  1242.             line, BlankLine: LineType;
  1243.             TheInfo: FInfo;
  1244.     begin
  1245.         ImportTextFile := false;
  1246.         err := GetFInfo(name, RefNum, TheInfo);
  1247.         if TheInfo.fdType <> 'TEXT' then begin
  1248.                 PutMessage('File is not of type ''TEXT''.');
  1249.                 exit(ImportTextFile);
  1250.             end;
  1251.         InitTextInput(name, RefNum);
  1252.         nRows := 0;
  1253.         nColumns := 0;
  1254.         max := -10e-10;
  1255.         min := 10e10;
  1256.         ShowMessage(concat('First pass used to find ', cr, 'width, height,min, and max.', cr, cr, CmdPeriodToStop));
  1257.         DrawLabels('Line:', '', '');
  1258.         while not TextEof do begin
  1259.                 GetLineFromText(rLine, count);
  1260.                 if not (TextEof and (count = 0)) then
  1261.                     nRows := nRows + 1;
  1262.                 if count > nColumns then
  1263.                     nColumns := count;
  1264.                 for i := 1 to count do begin
  1265.                         pvalue := rLine[i];
  1266.                         if pvalue > max then
  1267.                             max := pvalue;
  1268.                         if pvalue < min then
  1269.                             min := pvalue;
  1270.                     end;
  1271.                 if nRows mod 10 = 0 then begin
  1272.                         Show1Value(nRows, NoValue);
  1273.                         if CommandPeriod then begin
  1274.                                 beep;
  1275.                                 err := fsclose(Textf);
  1276.                                 Exit(ImportTextFile);
  1277.                             end;
  1278.                     end;
  1279.             end;
  1280.         ShowMessage(concat('rows= ', long2str(nRows), cr, 'columns= ', long2str(ncolumns), cr, 'min= ', long2str(round(min)), cr, 'max= ', long2str(round(max))));
  1281.         if nColumns > MaxLine then begin
  1282.                 PutMessage('More than 2048 pixels per line.');
  1283.                 Exit(ImportTextFile);
  1284.             end;
  1285.         nPixelsPerLine := nColumns;
  1286.         if NewPicWindow(name, nPixelsPerLine, nrows) then
  1287.             with info^ do begin
  1288.                     if (not ImportAutoScale) and (max > min) then begin
  1289.                             min := ImportMin;
  1290.                             max := ImportMax;
  1291.                         end;
  1292.                     ScaleFactor := 253.0 / (max - min);
  1293.                     InitTextInput(name, RefNum);
  1294.                     vloc := 0;
  1295.                     DefaultValue := 0.0;
  1296.                     if DefaultValue < min then
  1297.                         DefaultValue := min;
  1298.                     if DefaultValue > max then
  1299.                         DefaultValue := max;
  1300.                     BlankPixel := round((DefaultValue - min) * ScaleFactor + 1);
  1301.                     for i := 0 to nColumns - 1 do
  1302.                         BlankLine[i] := BlankPixel;
  1303.                     DrawLabels('Line:', 'Total:', '');
  1304.                     while not TextEof do begin
  1305.                             GetLineFromText(rLine, count);
  1306.                             if not (TextEof and (count = 0)) then begin
  1307.                                     line := BlankLine;
  1308.                                     if ImportAutoScale then     {Map values into the range 1-254}
  1309.                                         for i := 1 to count do
  1310.                                             line[i - 1] := round((rLine[i] - min) * ScaleFactor + 1)
  1311.                                     else
  1312.                                         for i := 1 to count do begin
  1313.                                                 tvalue := rLine[i];
  1314.                                                 if tvalue < min then
  1315.                                                     tvalue := min;
  1316.                                                 if tvalue > max then
  1317.                                                     tvalue := max;
  1318.                                                 line[i - 1] := round((tvalue - min) * ScaleFactor + 1);
  1319.                                             end;
  1320.                                     PutLine(0, vloc, PixelsPerLine, line);
  1321.                                     vloc := vloc + 1;
  1322.                                 end;
  1323.                             if vloc mod 10 = 0 then begin
  1324.                                     Show2Values(vloc, nRows);
  1325.                                     if CommandPeriod then begin
  1326.                                             beep;
  1327.                                             err := fsclose(Textf);
  1328.                                             Exit(ImportTextFile);
  1329.                                         end;
  1330.                                 end;
  1331.                         end;
  1332.                     fit := StraightLine;
  1333.                     nCoefficients := 2;
  1334.                     coefficient[2] := (max - min) / 253.0;
  1335.                     coefficient[1] := min - coefficient[2];
  1336.                     DensityCalibrated := true;
  1337.                     UpdateTitleBar;
  1338.                     ZeroClip := false;
  1339.                     changes := true;
  1340.                     PictureType := imported;
  1341.                 end; {with}
  1342.         ImportTextFile := true;
  1343.     end;
  1344.  
  1345.  
  1346.     procedure PlotXYZ;
  1347. {Reads X-Y coordinate pairs and optional intensiy(Z) values from a}
  1348. {two or three column tab-delimited text file and plots them in the current window.}
  1349.         var
  1350.             fname, str: str255;
  1351.             RefNum, i, nColumns, nValues, index, wheight: integer;
  1352.             rLine: RealLine;
  1353.     begin
  1354.         RefNum := 0;
  1355.         if not GetTextFile(fname, RefNum) then
  1356.             exit(PlotXYZ);
  1357.         InitTextInput(fname, RefNum);
  1358.         GetLineFromText(rLine, nValues);
  1359.         nColumns := nValues;
  1360.         if not ((nColumns = 2) or (nColumns = 3)) then begin
  1361.                 PutMessage('File must have two or three columns.');
  1362.                 exit(PlotXYZ);
  1363.             end;
  1364.         wheight := info^.nLines;
  1365.         index := ForegroundIndex;
  1366.         repeat
  1367.             if nColumns = 3 then begin
  1368.                     index := round(rLine[3]);
  1369.                     if index > 255 then
  1370.                         index := 255;
  1371.                     if index < 0 then
  1372.                         index := 0;
  1373.                 end;
  1374.             PutPixel(round(rLine[1]), wheight - round(rLine[2] + 1), index);
  1375.             GetLineFromText(rLine, nValues);
  1376.         until nValues = 0;
  1377.         InitCursor;
  1378.     end;
  1379.  
  1380.  
  1381. {$IFC false}
  1382.  
  1383.     procedure SaveDefaultWorkingDir (var settings: SettingsType);
  1384.         var
  1385.             DefaultVRefNum, err: integer;
  1386.             DefaultDirID: LongInt;
  1387.             ProcID: LongInt;
  1388.     begin
  1389.         with settings do begin
  1390.                 if DefaultRefNum <> 0 then begin
  1391.                         err := GetWDInfo(DefaultRefNum, DefaultVRefNum, DefaultDirID, ProcID);
  1392.                         if err = NoErr then begin
  1393.                                 sDefaultVRefNum := DefaultVRefNum;
  1394.                                 sDefaultDirID := DefaultDirID;
  1395.                             end
  1396.                         else
  1397.                             beep;
  1398.                     end;
  1399.        {ShowMessage(concat('KernelsRefNum=', long2str(KernelsRefNum), cr, 'vRefNum=', long2str(sKernelsVRefNum), cr, 'DirID=', long2str(sKernelsDirID)));}
  1400.             end; {with}
  1401.     end;
  1402.  
  1403.  
  1404.     procedure SaveKernelsWorkingDir (var settings: SettingsType);
  1405.         var
  1406.             KernelsVRefNum, err: integer;
  1407.             KernelsDirID: LongInt;
  1408.             ProcID: LongInt;
  1409.     begin
  1410.         with settings do begin
  1411.                 if KernelsRefNum <> 0 then begin
  1412.                         err := GetWDInfo(KernelsRefNum, KernelsVRefNum, KernelsDirID, ProcID);
  1413.                         if err = NoErr then begin
  1414.                                 sKernelsVRefNum := KernelsVRefNum;
  1415.                                 sKernelsDirID := KernelsDirID;
  1416.                             end
  1417.                         else
  1418.                             beep;
  1419.                     end;
  1420.       {ShowMessage(concat('KernelsRefNum=', long2str(KernelsRefNum), cr, 'vRefNum=', long2str(sKernelsVRefNum), cr, 'DirID=', long2str(sKernelsDirID)));}
  1421.             end; {with}
  1422.     end;
  1423. {$ENDC}
  1424.  
  1425.  
  1426.     procedure SaveSettings;
  1427.         var
  1428.             TheInfo: FInfo;
  1429.             ByteCount: LongInt;
  1430.             f, i: integer;
  1431.             err: OSErr;
  1432.             settings: SettingsType;
  1433.     begin
  1434.         with settings, info^ do begin
  1435.                 sID := 'IMAG';
  1436.                 sVersion := version;
  1437.                 sForegroundIndex := ForegroundIndex;
  1438.                 sBackgroundIndex := BackgroundIndex;
  1439.                 sBrushHeight := BrushHeight;
  1440.                 sBrushWidth := BrushWidth;
  1441.                 sSprayCanDiameter := SprayCanDiameter;
  1442.                 sLUTMode := LUTMode;
  1443.                 sOldColorStart := 30;
  1444.                 sOldColorWidth := 10;
  1445.                 sCurrentFontID := CurrentFontID;
  1446.                 sCurrentStyle := CurrentStyle;
  1447.                 sCurrentSize := CurrentSize;
  1448.                 sTextJust := TextJust;
  1449.                 sTextBack := TextBack;
  1450.                 sNExtraColors := nExtraColors;
  1451.                 sExtraColors := ExtraColors;
  1452.                 sInvertVideo := InvertVideo;
  1453.                 sMeasurements := Measurements;
  1454.                 sInvertPlots := InvertPlots;
  1455.                 sAutoScalePlots := AutoScalePlots;
  1456.                 sLinePlot := LinePlot;
  1457.                 sDrawPlotLabels := DrawPlotLabels;
  1458.                 for i := 1 to 12 do
  1459.                     sUnused1[i] := 0;
  1460.                 sFixedSizePlot := FixedSizePlot;
  1461.                 sProfilePlotWidth := ProfilePlotWidth;
  1462.                 sProfilePlotHeight := ProfilePlotHeight;
  1463.                 sFramesToAverage := FramesToAverage;
  1464.                 sNewPicWidth := NewPicWidth;
  1465.                 sNewPicHeight := NewPicHeight;
  1466.                 sBufferSize := BufferSize;
  1467.                 sMaxScionWidth := MaxScionWidth;
  1468.                 sThresholdToForeground := ThresholdToForeground;
  1469.                 sNonThresholdToBackground := NonThresholdToBackground;
  1470.                 sVideoChannel := VideoChannel;
  1471.                 sWhatToImport := WhatToImport;
  1472.                 sImportCustomWidth := ImportCustomWidth;
  1473.                 sImportCustomHeight := ImportCustomHeight;
  1474.                 sImportCustomOffset := ImportCustomOffset;
  1475.                 sWandAutoMeasure := WandAutoMeasure;
  1476.                 sWandAdjustAreas := WandAdjustAreas;
  1477.                 sBinaryIterations := BinaryIterations;
  1478.                 sScaleArithmetic := ScaleArithmetic;
  1479.                 sInvertPixelValues := InvertPixelValues;
  1480.                 sInvertYCoordinates := InvertYCoordinates;
  1481.                 sFieldWidth := FieldWidth;
  1482.                 sPrecision := precision;
  1483.                 sMinParticleSize := MinParticleSize;
  1484.                 sMaxParticleSize := MaxParticleSize;
  1485.                 sIgnoreParticlesTouchingEdge := IgnoreParticlesTouchingEdge;
  1486.                 sLabelParticles := LabelParticles;
  1487.                 sOutlineParticles := OutlineParticles;
  1488.                 sIncludeHoles := IncludeHoles;
  1489.                 sOscillatingMovies := OscillatingMovies;
  1490.                 sDriverHalftoning := DriverHalftoning;
  1491.                 sMaxMeasurements := MaxMeasurements;
  1492.                 sImportCustomDepth := ImportCustomDepth;
  1493.                 sImportSwapBytes := ImportSwapBytes;
  1494.                 sImportCalibrate := ImportCalibrate;
  1495.                 sImportAutoscale := ImportAutoscale;
  1496.                 for i := 1 to 12 do
  1497.                     sUnused2[i] := 0;
  1498.                 sShowHeadings := ShowHeadings;
  1499.                 sDefaultVRefNum := 0;
  1500.                 sDefaultDirID := 0;
  1501.                 sKernelsVRefNum := 0;
  1502.                 sKernelsDirID := 0;
  1503.         {***}
  1504.                 sProfilePlotMin := ProfilePlotMin;
  1505.                 sProfilePlotMax := ProfilePlotMax;
  1506.                 sImportMin := ImportMin;
  1507.                 sImportMax := ImportMax;
  1508.                 sHighlightPixels := HighlightSaturatedPixels;
  1509.         {***}
  1510.                 sBallRadius := BallRadius;
  1511.                 sFasterBackgroundSubtraction := FasterBackgroundSubtraction;
  1512.                 sScaleConvolutions := ScaleConvolutions;
  1513.         {V1.42}
  1514.                 sBinaryCount := BinaryCount;
  1515.                 sColorTable := ColorTable;
  1516.                 sColorStart := ColorStart;
  1517.                 sColorEnd := ColorEnd;
  1518.                 sInvertedTable := InvertedColorTable;
  1519.         {V1.44}
  1520.                 sHalftoneFrequency := HalftoneFrequency;
  1521.                 sHalftoneAngle := HalftoneAngle;
  1522.                 sHalftoneDotFunction := HalftoneDotFunction;
  1523.                 sLG3DacLow := LG3DacLow;
  1524.                 sLG3DacHigh := LG3DacHigh;
  1525.                 sSyncMode := SyncMode;
  1526.                 sSwitchLUTOnSuspend := SwitchLUTOnSuspend;
  1527.                 sVideoRateAveraging := VideoRateAveraging;
  1528.                 sImportInvert := ImportInvert;
  1529.                 sTextCreator := TextCreator;
  1530.                 for i := 1 to 10 do
  1531.                     sUnused[i] := 0;
  1532.             end; {with}
  1533. {PBGetWDInfo seems to crash a lot, particularly under System 7. Does anyone know why?}
  1534. {SaveDefaultWorkingDir(settings);}
  1535. {SaveKernelsWorkingDir(settings);}
  1536.         err := GetFInfo(PrefsName, SystemRefNum, TheInfo);
  1537.         if err = FNFerr then begin
  1538.                 err := create(PrefsName, SystemRefNum, 'Imag', 'PREF');
  1539.                 if CheckIO(err) <> 0 then
  1540.                     exit(SaveSettings);
  1541.             end;
  1542.         err := fsopen(PrefsName, SystemRefNum, f);
  1543.         if CheckIO(err) <> 0 then
  1544.             exit(SaveSettings);
  1545.         err := SetFPos(f, FSFromStart, 0);
  1546.         ByteCount := SizeOf(settings);
  1547.         err := fswrite(f, ByteCount, @settings);
  1548.         if CheckIO(err) <> 0 then begin
  1549.                 err := fsclose(f);
  1550.                 exit(SaveSettings)
  1551.             end;
  1552.         err := SetEof(f, ByteCount);
  1553.         err := fsclose(f);
  1554.         err := FlushVol(nil, SystemRefNum);
  1555.     end;
  1556.  
  1557.  
  1558.     procedure ExportAsText (fname: str255; RefNum: integer);
  1559.         var
  1560.             err, f, width, hloc, vloc: integer;
  1561.             TheInfo: FInfo;
  1562.             ByteCount, FileSize: LongInt;
  1563.             AutoSelectAll: boolean;
  1564.             tLine: LineType;
  1565.     begin
  1566.         err := GetFInfo(fname, RefNum, TheInfo);
  1567.         case err of
  1568.             NoErr: 
  1569.                 if TheInfo.fdType <> 'TEXT' then begin
  1570.                         TypeMismatch(fname);
  1571.                         exit(ExportAsText)
  1572.                     end;
  1573.             FNFerr:  begin
  1574.                     err := create(fname, RefNum, TextCreator, 'TEXT');
  1575.                     if CheckIO(err) <> 0 then
  1576.                         exit(ExportAsText);
  1577.                 end;
  1578.             otherwise
  1579.                 if CheckIO(err) <> 0 then
  1580.                     exit(ExportAsText)
  1581.         end;
  1582.         ShowWatch;
  1583.         err := fsopen(fname, RefNum, f);
  1584.         if CheckIO(err) <> 0 then
  1585.             exit(ExportAsText);
  1586.         AutoSelectAll := not info^.RoiShowing;
  1587.         if AutoSelectAll then
  1588.             SelectAll(true);
  1589.         if TooWide then
  1590.             exit(ExportAsText);
  1591.         FileSize := 0;
  1592.         with info^.RoiRect do begin
  1593.                 width := right - left;
  1594.                 for vloc := top to bottom - 1 do begin
  1595.                         GetLine(left, vloc, width, tLine);
  1596.                         TextBufSize := 0;
  1597.                         for hloc := 0 to width - 1 do begin
  1598.                                 PutLong(tLine[hloc], 0);
  1599.                                 if hloc <> (width - 1) then
  1600.                                     PutTab;
  1601.                             end;
  1602.                         PutChar(cr);
  1603.                         ByteCount := TextBufSize;
  1604.                         err := fswrite(f, ByteCount, ptr(TextBufP));
  1605.                         FIleSize := FileSize + ByteCount;
  1606.                         if (CheckIO(err) <> 0) or CommandPeriod then
  1607.                             leave;
  1608.                     end;
  1609.                 err := SetEof(f, FileSize);
  1610.                 err := fsclose(f);
  1611.                 err := FlushVol(nil, RefNum);
  1612.             end;
  1613.         if AutoSelectAll then
  1614.             KillRoi;
  1615.     end;
  1616.  
  1617.  
  1618.     procedure ExportCoordinates (fname: str255; RefNum: integer);
  1619.         var
  1620.             err, f, i, y: integer;
  1621.             TheInfo: FInfo;
  1622.             ByteCount, FileSize: LongInt;
  1623.             InvertY: boolean;
  1624.     begin
  1625.         if not CoordinatesAvailableMsg then begin
  1626.                 exit(ExportCoordinates)
  1627.             end;
  1628.         err := GetFInfo(fname, RefNum, TheInfo);
  1629.         case err of
  1630.             NoErr: 
  1631.                 if TheInfo.fdType <> 'TEXT' then begin
  1632.                         TypeMismatch(fname);
  1633.                         exit(ExportCoordinates)
  1634.                     end;
  1635.             FNFerr:  begin
  1636.                     err := create(fname, RefNum, TextCreator, 'TEXT');
  1637.                     if CheckIO(err) <> 0 then
  1638.                         exit(ExportCoordinates);
  1639.                 end;
  1640.             otherwise
  1641.                 if CheckIO(err) <> 0 then
  1642.                     exit(ExportCoordinates)
  1643.         end;
  1644.         ShowWatch;
  1645.         err := fsopen(fname, RefNum, f);
  1646.         if CheckIO(err) <> 0 then
  1647.             exit(ExportCoordinates);
  1648.         FileSize := 0;
  1649.         InvertY := InvertYCoordinates and (Info <> NoInfo);
  1650.         with info^ do
  1651.             for i := 1 to nCoordinates do begin
  1652.                     TextBufSize := 0;
  1653.                     PutLong(xCoordinates^[i] + RoiRect.left, 0);
  1654.                     PutTab;
  1655.                     y := yCoordinates^[i] + RoiRect.top;
  1656.                     if InvertY then
  1657.                         y := PicRect.bottom - y - 1;
  1658.                     PutLong(y, 0);
  1659.                     PutChar(cr);
  1660.                     ByteCount := TextBufSize;
  1661.                     err := fswrite(f, ByteCount, ptr(TextBufP));
  1662.                     FIleSize := FileSize + ByteCount;
  1663.                     if (CheckIO(err) <> 0) or CommandPeriod then
  1664.                         leave;
  1665.                 end;
  1666.         err := SetEof(f, FileSize);
  1667.         err := fsclose(f);
  1668.         err := FlushVol(nil, RefNum);
  1669.     end;
  1670.  
  1671.  
  1672.     procedure ExportMeasurements (fname: str255; RefNum: integer);
  1673.         const
  1674.             LinesPerPass = 25;
  1675.         var
  1676.             err, f, i, first, last: integer;
  1677.             TheInfo: FInfo;
  1678.             ByteCount, FileSize: LongInt;
  1679.     begin
  1680.         err := GetFInfo(fname, RefNum, TheInfo);
  1681.         case err of
  1682.             NoErr: 
  1683.                 if TheInfo.fdType <> 'TEXT' then begin
  1684.                         TypeMismatch(fname);
  1685.                         exit(ExportMeasurements)
  1686.                     end;
  1687.             FNFerr:  begin
  1688.                     err := create(fname, RefNum, TextCreator, 'TEXT');
  1689.                     if CheckIO(err) <> 0 then
  1690.                         exit(ExportMeasurements);
  1691.                 end;
  1692.             otherwise
  1693.                 if CheckIO(err) <> 0 then
  1694.                     exit(ExportMeasurements)
  1695.         end;
  1696.         ShowWatch;
  1697.         err := fsopen(fname, RefNum, f);
  1698.         if CheckIO(err) <> 0 then
  1699.             exit(ExportMeasurements);
  1700.         FileSize := 0;
  1701.         first := 1;
  1702.         last := LinesPerPass;
  1703.         repeat
  1704.             if last > mCount then
  1705.                 last := mCount;
  1706.             CopyResultsToBuffer(first, last, ShowHeadings or OptionKeyWasDown);
  1707.             ByteCount := TextBufSize;
  1708.             err := fswrite(f, ByteCount, ptr(TextBufP));
  1709.             FIleSize := FileSize + ByteCount;
  1710.             if (CheckIO(err) <> 0) or CommandPeriod or (last = mCount) then
  1711.                 leave;
  1712.             first := first + LinesPerPass;
  1713.             last := last + LinesPerPass;
  1714.         until false;
  1715.         err := SetEof(f, FileSize);
  1716.         err := fsclose(f);
  1717.         err := FlushVol(nil, RefNum);
  1718.         UnsavedResults := false;
  1719.     end;
  1720.  
  1721.  
  1722.     procedure Swap2Bytes (var i: integer);
  1723.         type
  1724.             atype = packed array[1..2] of char;
  1725.         var
  1726.             a: atype;
  1727.             c: char;
  1728.     begin
  1729.         a := atype(i);
  1730.         c := a[1];
  1731.         a[1] := a[2];
  1732.         a[2] := c;
  1733.         i := integer(a)
  1734.     end;
  1735.  
  1736.  
  1737.     procedure Swap4Bytes (var i: LongInt);
  1738.         var
  1739.             a: ostype;
  1740.             c: char;
  1741.     begin
  1742.         a := ostype(i);
  1743.         c := a[1];
  1744.         a[1] := a[4];
  1745.         a[4] := c;
  1746.         c := a[2];
  1747.         a[2] := a[3];
  1748.         a[3] := c;
  1749.         i := LongInt(a)
  1750.     end;
  1751.  
  1752.  
  1753.     function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean;
  1754.         var
  1755.             TiffHeader: TiffHdr;
  1756.             ByteCount: LongInt;
  1757.             err: OSErr;
  1758.     begin
  1759.         ByteCount := 8;
  1760.         err := SetFPos(f, fsFromStart, 0);
  1761.         err := fsread(f, ByteCount, @TiffHeader);
  1762.         if CheckIO(err) <> NoErr then begin
  1763.                 OpenTiffHeader := false;
  1764.                 exit(OpenTiffHeader);
  1765.             end;
  1766.         with TiffHeader do begin
  1767.                 IntelByteOrder := ByteOrder = 'II';
  1768.                 if (ByteOrder <> 'MM') and (ByteOrder <> 'II') then begin
  1769.                         PutMessage('Invalid TIFF header.');
  1770.                         OpenTiffHeader := false;
  1771.                         exit(OpenTiffHeader)
  1772.                     end;
  1773.                 DirOffset := FirstIFDOffset;
  1774.                 if IntelByteOrder then
  1775.                     Swap4Bytes(DirOffset);
  1776.                 OpenTiffHeader := true;
  1777.             end;
  1778.     end;
  1779.  
  1780.  
  1781.     procedure GetTiffEntry (f: integer; var tag: integer; var N, value: LongInt);
  1782.         var
  1783.             IFDEntry: TiffEntry;
  1784.             ByteCount: LongInt;
  1785.             IntValue: integer;
  1786.             err: OSErr;
  1787.             str: str255;
  1788.     begin
  1789.         ByteCount := 12;
  1790.         err := FSRead(f, ByteCount, @IFDEntry);
  1791.         with IFDEntry do begin
  1792.                 tag := TagField;
  1793.                 N := length;
  1794.                 if IntelByteOrder then begin
  1795.                         Swap2Bytes(tag);
  1796.                         Swap2Bytes(ftype);
  1797.                         Swap4Bytes(N);
  1798.                     end;
  1799.                 value := offset;
  1800.                 if (ftype = short) and (N = 1) then begin
  1801.                         value := bsr(value, 16);
  1802.                         if IntelByteOrder then begin
  1803.                                 IntValue := value;
  1804.                                 Swap2Bytes(IntValue);
  1805.                                 value := IntValue
  1806.                             end
  1807.                     end
  1808.                 else if IntelByteOrder then
  1809.                     Swap4Bytes(value);
  1810.                 if OptionKeyWasDown then begin
  1811.                         gstr := concat(gstr, long2str(tag), '  ', long2str(ftype), '  ', long2str(N), '  ', long2str(value), cr);
  1812.                         ShowMessage(gstr);
  1813.                     end;
  1814.             end;
  1815.     end;
  1816.  
  1817.  
  1818.     function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec): boolean;
  1819.         const
  1820.             NoUnit = 1;
  1821.             inch = 2;
  1822.             centimeter = 3;
  1823.         var
  1824.             ByteCount, length, ftype, N, value, BytesPerStrip, SaveFPos: LongInt;
  1825.             err: OSErr;
  1826.             nEntries, i, tag, entry: integer;
  1827.             StripOffsetsArray: array[1..2] of LongInt;
  1828.             xRes, yRes: extended;
  1829.  
  1830.         function GetResolution: extended;
  1831.             var
  1832.                 resolution: array[1..2] of LongInt;
  1833.         begin
  1834.             err := GetFPos(f, SaveFPos);
  1835.             err := SetFPos(f, fsFromStart, value);
  1836.             ByteCount := 8;
  1837.             err := fsread(f, ByteCount, @Resolution);
  1838.             if IntelByteOrder then begin
  1839.                     Swap4Bytes(Resolution[1]);
  1840.                     Swap4Bytes(Resolution[2]);
  1841.                 end;
  1842.             err := SetFPos(f, fsFromStart, SaveFPos);
  1843.             if resolution[2] <> 0 then
  1844.                 GetResolution := resolution[1] / resolution[2]
  1845.             else
  1846.                 GetResolution := 0.0;
  1847.         end;
  1848.  
  1849.     begin
  1850.         if OptionKeyWasDown then
  1851.             gstr := '';
  1852.         xRes := 0.0;
  1853.         err := SetFPos(f, fsFromStart, DirOffset);
  1854.         ByteCount := 2;
  1855.         err := FSRead(f, ByteCount, @nEntries);
  1856.         if CheckIO(err) <> NoErr then begin
  1857.                 OpenTiffDirectory := false;
  1858.                 exit(OpenTiffDirectory);
  1859.             end;
  1860.         if IntelByteOrder then
  1861.             Swap2Bytes(nEntries);
  1862.         with TiffInfo do begin
  1863.                 width := 0;
  1864.                 height := 0;
  1865.                 BitsPerPixel := 1;
  1866.                 OffsetToData := 0;
  1867.                 Resolution := 0.0;
  1868.                 ResUnits := tNoUnits;
  1869.                 OffsetToColorMap := 0;
  1870.                 OffsetToImageHeader := -1;
  1871.                 for entry := 1 to nEntries do begin
  1872.                         GetTiffEntry(f, tag, N, value);
  1873.                         if tag = 0 then begin
  1874.                                 PutMessage('Invalid TIFF format.');
  1875.                                 OpenTiffDirectory := false;
  1876.                                 exit(OpenTiffDirectory)
  1877.                             end;
  1878.                         case tag of
  1879.                             ImageWidth: 
  1880.                                 width := value;
  1881.                             ImageLength: 
  1882.                                 height := value;
  1883.                             BitsPerSample:  begin
  1884.                                     BitsPerPixel := value;
  1885.                                     if value = 1 then begin
  1886.                                             PutMessage('Image cannot open 1-bit TIFF files.');
  1887.                                             OpenTiffDirectory := false;
  1888.                                             exit(OpenTiffDirectory)
  1889.                                         end;
  1890.                                 end;
  1891.                             SamplesPerPixel: 
  1892.                                 if value > 1 then begin
  1893.                                         PutMessage('Image cannot open 24-bit files.');
  1894.                                         OpenTiffDirectory := false;
  1895.                                         exit(OpenTiffDirectory)
  1896.                                     end;
  1897.                             Compression: 
  1898.                                 if value <> 1 then begin
  1899.                                         PutMessage('Image cannot open compressed TIFF files.');
  1900.                                         OpenTiffDirectory := false;
  1901.                                         exit(OpenTiffDirectory)
  1902.                                     end;
  1903.                             PhotoInterp: 
  1904.                                 ZeroIsBlack := value = 1;
  1905.                             StripOffsets: 
  1906.                                 if N = 1 then
  1907.                                     OffsetToData := value
  1908.                                 else begin
  1909.                                         err := GetFPos(f, SaveFPos);
  1910.                                         err := SetFPos(f, fsFromStart, value);
  1911.                                         ByteCount := 8;
  1912.                                         err := fsread(f, ByteCount, @StripOffsetsArray);
  1913.                                         if IntelByteOrder then begin
  1914.                                                 Swap4Bytes(StripOffsetsArray[1]);
  1915.                                                 Swap4Bytes(StripOffsetsArray[2]);
  1916.                                             end;
  1917.                                         err := SetFPos(f, fsFromStart, SaveFPos);
  1918.                                     end;
  1919.                             RowsPerStrip: 
  1920.                                 if value < height then begin
  1921.                                         if BitsPerPixel = 16 then
  1922.                                             BytesPerStrip := value * width * 2
  1923.                                         else
  1924.                                             BytesPerStrip := value * width;
  1925.                                         if StripOffsetsArray[2] <> (StripOffsetsArray[1] + BytesPerStrip) then begin
  1926.                                                 PutMessage('Image cannot open TIFF files with discontiguous strips.');
  1927.                                                 OpenTiffDirectory := false;
  1928.                                                 exit(OpenTiffDirectory)
  1929.                                             end;
  1930.                                         OffsetToData := StripOffsetsArray[1];
  1931.                                     end;
  1932.                             XResolution: 
  1933.                                 XRes := GetResolution;
  1934.                             YResolution:  begin
  1935.                                     yRes := GetResolution;
  1936.                                     if (xRes = yRes) and (xRes > 0.0) then begin
  1937.                                             resolution := xRes;
  1938.                                             ResUnits := tInches;
  1939.                                         end;
  1940.                                 end;
  1941.                             ResolutionUnit: 
  1942.                                 case value of
  1943.                                     NoUnit: 
  1944.                                         ResUnits := tNoUnits;
  1945.                                     Centimeter: 
  1946.                                         ResUnits := tCentimeters;
  1947.                                     otherwise
  1948.                                 end;
  1949.                             ColorMapTag: 
  1950.                                 if N = 768 then
  1951.                                     OffsetToColorMap := value;
  1952.                             ImageHdrTag: 
  1953.                                 OffsetToImageHeader := value;
  1954.                             otherwise
  1955.                         end;
  1956.                     end; {for}
  1957.                 ByteCount := 4;
  1958.                 err := FSRead(f, ByteCount, @NextIFD);
  1959.                 if IntelByteOrder then
  1960.                     Swap4Bytes(NextIFD);
  1961.                 if OptionKeyWasDown then begin
  1962.                         gstr := concat(gstr, 'Next IFD=', long2str(NextIFD));
  1963.                         ShowMessage(gstr);
  1964.                     end;
  1965.                 if width = 0 then begin
  1966.                         PutMessage('Error opening TIFF directory');
  1967.                         OpenTiffDirectory := false;
  1968.                         exit(OpenTiffDirectory)
  1969.                     end;
  1970.             end; {with}
  1971.         OpenTiffDirectory := true;
  1972.     end;
  1973.  
  1974.  
  1975.     procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt);
  1976.         var
  1977.             i: integer;
  1978.             err: OSErr;
  1979.             ColorMap: TiffColorMapType;
  1980.             ColorMapSize: LongInt;
  1981.     begin
  1982.         LoadLUT(info^.cTable);
  1983.         for i := 0 to 255 do
  1984.             with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin
  1985.                     ColorMap[1, i] := red;
  1986.                     ColorMap[2, i] := green;
  1987.                     ColorMap[3, i] := blue;
  1988.                 end;
  1989.         err := SetFPos(f, FSFromStart, HeaderSize + TiffDirSize + ImageDataSize);
  1990.         ColorMapSize := SizeOf(ColorMap);
  1991.         err := fswrite(f, ColorMapSize, @ColorMap);
  1992.         if CheckIO(err) <> 0 then
  1993.             beep;
  1994.     end;
  1995.  
  1996.  
  1997.     procedure GetTiffColorMap (f: integer);
  1998.         var
  1999.             i: integer;
  2000.             ByteCount: LongInt;
  2001.             err: OSErr;
  2002.             ColorMap: TiffColorMapType;
  2003.     begin
  2004.         with info^ do begin
  2005.                 ByteCount := SizeOf(ColorMap);
  2006.                 err := SetFPos(f, fsFromStart, ColorMapOffset);
  2007.                 err := fsRead(f, ByteCount, @ColorMap);
  2008.                 if err = NoErr then begin
  2009.                         if IntelByteOrder then
  2010.                             for i := 0 to 255 do begin
  2011.                                     Swap2Bytes(ColorMap[1, i]);
  2012.                                     Swap2Bytes(ColorMap[2, i]);
  2013.                                     Swap2Bytes(ColorMap[3, i]);
  2014.                                 end;
  2015.                         for i := 0 to 255 do
  2016.                             with cTable[i].rgb do begin
  2017.                                     red := ColorMap[1, i];
  2018.                                     green := ColorMap[2, i];
  2019.                                     blue := ColorMap[3, i];
  2020.                                 end;
  2021.                         LoadLUT(cTable);
  2022.                         LUTMode := ColorLut;
  2023.                         SetupPseudocolor;
  2024.                         IdentityFunction := false;
  2025.                         if isGrayScaleLUT then begin
  2026.                                 info^.LutMode := CustomGrayScale;
  2027.                                 DrawMap;
  2028.                             end;
  2029.                     end
  2030.                 else
  2031.                     beep;
  2032.             end;{with}
  2033.     end;
  2034.  
  2035.  
  2036.     function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr;
  2037.         var
  2038.             i: integer;
  2039.             err: OSErr;
  2040.             ByteCount, width, height: LongInt;
  2041.             TiffInfo1: record
  2042.                     Header: TiffHdr;   {8}
  2043.                     nEntries: integer; {2}
  2044.                     TiffDir: array[1..8] of TiffEntry; {96}
  2045.                 end;
  2046.             ColorMapEntry: TiffEntry;  {12(Optional)}
  2047.             TiffInfo2: record
  2048.                     ImageHdrEntry: TiffEntry;  {12}
  2049.                     NextIFD: LongInt;  {4}
  2050.                     filler: array[1..TiffFillerSize] of integer; {134}
  2051.                 end;
  2052.     begin
  2053.         with info^ do begin
  2054.                 if SavingSelection then begin
  2055.                         width := sPixelsPerLine;
  2056.                         height := sLines
  2057.                     end
  2058.                 else begin
  2059.                         width := PixelsPerLine;
  2060.                         height := nLines
  2061.                     end;
  2062.                 with TiffInfo1 do begin
  2063.                         with header do begin
  2064.                                 ByteOrder := 'MM';
  2065.                                 Version := 42;
  2066.                                 FirstIFDOffset := 8;
  2067.                             end;
  2068.                         if ctabSize > 0 then
  2069.                             nEntries := 10
  2070.                         else
  2071.                             nEntries := 9;
  2072.                         for i := 1 to 8 do
  2073.                             with TiffDir[i] do begin
  2074.                                     ftype := 3;
  2075.                                     length := 1
  2076.                                 end;
  2077.                         with TiffDir[1] do begin
  2078.                                 TagField := NewSubfileType;
  2079.                                 ftype := 4;
  2080.                                 offset := 0;
  2081.                             end;
  2082.                         with TiffDir[2] do begin
  2083.                                 TagField := ImageWidth;
  2084.                                 offset := bsl(width, 16);
  2085.                             end;
  2086.                         with TiffDir[3] do begin
  2087.                                 TagField := ImageLength;
  2088.                                 offset := bsl(height, 16);
  2089.                             end;
  2090.                         with TiffDir[4] do begin
  2091.                                 TagField := BitsPerSample;
  2092.                                 offset := bsl(8, 16);
  2093.                             end;
  2094.                         with TiffDir[5] do begin
  2095.                                 TagField := PhotoInterp;
  2096.                                 if ctabSize > 0 then
  2097.                                     offset := bsl(3, 16)
  2098.                                 else
  2099.                                     offset := 0;
  2100.                             end;
  2101.                         with TiffDir[6] do begin
  2102.                                 TagField := StripOffsets;
  2103.                                 ftype := 4;
  2104.                                 offset := TiffDirSize + HeaderSize;
  2105.                             end;
  2106.                         with TiffDir[7] do begin
  2107.                                 TagField := RowsPerStrip;
  2108.                                 offset := bsl(height, 16);
  2109.                             end;
  2110.                         with TiffDir[8] do begin
  2111.                                 TagField := StripByteCount;
  2112.                                 ftype := 4;
  2113.                                 offset := width * height;
  2114.                             end;
  2115.                     end;
  2116.                 ByteCount := SizeOf(TiffInfo1);
  2117.                 err := SetFPos(f, FSFromStart, 0);
  2118.                 err := FSWrite(f, ByteCount, @TiffInfo1);
  2119.                 if CheckIO(err) <> NoErr then begin
  2120.                         SaveTiffDir := err;
  2121.                         exit(SaveTiffDir);
  2122.                     end;
  2123.                 if ctabSize > 0 then
  2124.                     with ColorMapEntry do begin
  2125.                             TagField := ColorMapTag;
  2126.                             ftype := 3;
  2127.                             length := 768;
  2128.                             offset := HeaderSize + TiffDirSize + ImageDataSize;
  2129.                             ByteCount := SizeOf(ColorMapEntry);
  2130.                             err := FSWrite(f, ByteCount, @ColorMapEntry);
  2131.                             if CheckIO(err) <> NoErr then begin
  2132.                                     SaveTiffDir := err;
  2133.                                     exit(SaveTiffDir);
  2134.                                 end;
  2135.                         end;
  2136.                 with TiffInfo2 do begin
  2137.                         with ImageHdrEntry do begin
  2138.                                 TagField := ImageHdrTag;
  2139.                                 ftype := 3;
  2140.                                 length := 256;
  2141.                                 offset := TiffDirSize;
  2142.                             end;
  2143.                         NextIFD := 0;
  2144.                         if StackInfo <> nil then
  2145.                             if StackInfo^.nSlices > 1 then
  2146.                                 NextIFD := HeaderSize + TiffDirSize + ImageDataSize + ctabSize;
  2147.                         for i := 1 to TiffFillerSize do
  2148.                             filler[i] := 0;
  2149.                     end;
  2150.             end;
  2151.         ByteCount := SizeOf(TiffInfo2);
  2152.         err := FSWrite(f, ByteCount, @TiffInfo2);
  2153.         SaveTiffDir := CheckIO(err);
  2154.     end;
  2155.  
  2156.  
  2157.     function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer;
  2158.         var
  2159.             IFD, entry: integer;
  2160.             StackIFD: StackIFDType;
  2161.             err: OSErr;
  2162.             IFDoffset, SliceOffset, ByteCount: LongInt;
  2163.     begin
  2164.         with info^, StackInfo^, StackIFD do begin
  2165.                 IFDoffset := HeaderSize + TiffDirSize + ImageDataSize + ctabSize;
  2166.                 err := SetFPos(f, FSFromStart, IFDoffset);
  2167.                 SliceOffset := HeaderSize + TiffDirSize + ImageSize;
  2168.                 for IFD := 2 to nSlices do  {IFD=Image File Directory}
  2169.                     begin
  2170.                         nEntries := 6;
  2171.                         for entry := 1 to nEntries do
  2172.                             with TiffDir[entry] do begin
  2173.                                     ftype := 3;
  2174.                                     length := 1
  2175.                                 end;
  2176.                         with TiffDir[1] do begin
  2177.                                 TagField := NewSubfileType;
  2178.                                 ftype := 4;
  2179.                                 offset := 0;
  2180.                             end;
  2181.                         with TiffDir[2] do begin
  2182.                                 TagField := ImageWidth;
  2183.                                 offset := bsl(PixelsPerLine, 16);
  2184.                             end;
  2185.                         with TiffDir[3] do begin
  2186.                                 TagField := ImageLength;
  2187.                                 offset := bsl(nLines, 16);
  2188.                             end;
  2189.                         with TiffDir[4] do begin
  2190.                                 TagField := BitsPerSample;
  2191.                                 offset := bsl(8, 16);
  2192.                             end;
  2193.                         with TiffDir[5] do begin
  2194.                                 TagField := PhotoInterp;
  2195.                                 offset := 0;
  2196.                             end;
  2197.                         with TiffDir[6] do begin
  2198.                                 TagField := StripOffsets;
  2199.                                 ftype := 4;
  2200.                                 offset := SliceOffset;
  2201.                             end;
  2202.                         SliceOffset := SliceOffset + ImageSize;
  2203.                         IFDoffset := IFDoffset + SizeOf(StackIFD);
  2204.                         if IFD <> nSlices then
  2205.                             NextIFD := IFDoffset
  2206.                         else
  2207.                             NextIFD := 0;
  2208.                         ByteCount := SizeOf(StackIFD);
  2209.                         err := fswrite(f, ByteCount, @StackIFD);
  2210.                         if err <> NoErr then begin
  2211.                                 WriteExtraTiffIFDs := err;
  2212.                                 exit(WriteExtraTiffIFDs);
  2213.                             end;
  2214.                     end; {for}
  2215.             end; {with}
  2216.         WriteExtraTiffIFDs := NoErr;
  2217.     end;
  2218.  
  2219.  
  2220.     procedure SaveLUT (fname: str255; RefNum: integer);
  2221.         var
  2222.             err: integer;
  2223.             TheInfo: FInfo;
  2224.             LUT: array[1..3] of packed array[0..255] of byte;
  2225.             i, f: integer;
  2226.             ByteCount: LongInt;
  2227.     begin
  2228.         err := GetFInfo(fname, RefNum, TheInfo);
  2229.         case err of
  2230.             NoErr: 
  2231.                 if TheInfo.fdType <> 'ICOL' then begin
  2232.                         TypeMismatch(fname);
  2233.                         exit(SaveLUT)
  2234.                     end;
  2235.             FNFerr:  begin
  2236.                     err := create(fname, RefNum, 'Imag', 'ICOL');
  2237.                     if CheckIO(err) <> 0 then
  2238.                         exit(SaveLUT);
  2239.                 end;
  2240.             otherwise
  2241.                 if CheckIO(err) <> 0 then
  2242.                     exit(SaveLUT);
  2243.         end;
  2244.         DisableDensitySlice;
  2245.         LoadLUT(Info^.cTable);
  2246.         for i := 0 to 255 do
  2247.             with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin
  2248.                     LUT[1, i] := band(bsr(red, 8), 255);
  2249.                     LUT[2, i] := band(bsr(green, 8), 255);
  2250.                     LUT[3, i] := band(bsr(blue, 8), 255);
  2251.                 end;
  2252.         err := fsopen(fname, RefNum, f);
  2253.         if CheckIO(err) <> 0 then
  2254.             exit(SaveLUT);
  2255.         err := SetFPos(f, FSFromStart, 0);
  2256.         ByteCount := SizeOf(LUT);
  2257.         err := fswrite(f, ByteCount, @LUT);
  2258.         if CheckIO(err) <> 0 then begin
  2259.                 err := fsclose(f);
  2260.                 err := FSDelete(fname, RefNum);
  2261.                 exit(SaveLUT)
  2262.             end;
  2263.         err := SetEof(f, ByteCount);
  2264.         err := fsclose(f);
  2265.         err := GetFInfo(fname, RefNum, TheInfo);
  2266.         if TheInfo.fdCreator <> 'Imag' then begin
  2267.                 TheInfo.fdCreator := 'Imag';
  2268.                 err := SetFInfo(fname, RefNum, TheInfo);
  2269.             end;
  2270.         err := FlushVol(nil, RefNum);
  2271.     end;
  2272.  
  2273.  
  2274.     procedure SaveColorTable (fname: str255; RefNum: integer);
  2275.         var
  2276.             err: integer;
  2277.             TheInfo: FInfo;
  2278.             i, f: integer;
  2279.             ByteCount: LongInt;
  2280.             hdr: PaletteHeader;
  2281.     begin
  2282.         with info^ do
  2283.             err := GetFInfo(fname, RefNum, TheInfo);
  2284.         case err of
  2285.             NoErr: 
  2286.                 if TheInfo.fdType <> 'ICOL' then begin
  2287.                         TypeMismatch(fname);
  2288.                         exit(SaveColorTable)
  2289.                     end;
  2290.             FNFerr:  begin
  2291.                     err := create(fname, RefNum, 'Imag', 'ICOL');
  2292.                     if CheckIO(err) <> 0 then
  2293.                         exit(SaveColorTable);
  2294.                 end;
  2295.             otherwise
  2296.                 if CheckIO(err) <> 0 then
  2297.                     exit(SaveColorTable);
  2298.         end;
  2299.         with info^ do begin
  2300.                 InitPaletteHeader(hdr);
  2301.                 err := fsopen(fname, RefNum, f);
  2302.                 if CheckIO(err) <> 0 then
  2303.                     exit(SaveColorTable);
  2304.                 err := SetFPos(f, FSFromStart, 0);
  2305.                 ByteCount := SizeOf(PaletteHeader);
  2306.                 if ByteCount <> 32 then
  2307.                     PutMessage('Palette header size <> 32.');
  2308.                 err := fswrite(f, ByteCount, @hdr);
  2309.                 ByteCount := nColors;
  2310.                 err := fswrite(f, ByteCount, @redLUT);
  2311.                 ByteCount := nColors;
  2312.                 err := fswrite(f, ByteCount, @greenLUT);
  2313.                 ByteCount := nColors;
  2314.                 err := fswrite(f, ByteCount, @blueLUT);
  2315.                 if CheckIO(err) <> 0 then begin
  2316.                         err := fsclose(f);
  2317.                         err := FSDelete(fname, RefNum);
  2318.                         exit(SaveColorTable)
  2319.                     end;
  2320.                 err := SetEOF(f, SizeOf(PaletteHeader) + 3 * nColors);
  2321.                 err := fsclose(f);
  2322.                 err := GetFInfo(fname, RefNum, TheInfo);
  2323.                 if TheInfo.fdCreator <> 'Imag' then begin
  2324.                         TheInfo.fdCreator := 'Imag';
  2325.                         err := SetFInfo(fname, RefNum, TheInfo);
  2326.                     end;
  2327.                 err := FlushVol(nil, RefNum);
  2328.             end; {with info^}
  2329.     end;
  2330.  
  2331.  
  2332.     procedure SaveOutline (fname: str255; RefNum: integer);
  2333.         var
  2334.             err: integer;
  2335.             TheInfo: FInfo;
  2336.             i, f: integer;
  2337.             ByteCount, DataSize: LongInt;
  2338.             hdr: RoiHeader;
  2339.             SaveCoordinates: boolean;
  2340.     begin
  2341.         with info^ do begin
  2342.                 if not RoiShowing then begin
  2343.                         PutMessage('No outline available to save.');
  2344.                         exit(SaveOutline);
  2345.                     end;
  2346.                 if (RoiType = FreeLineRoi) or (RoiType = SegLineRoi) then begin
  2347.                         PutMessage('Freehand and segmented line selections cannot be saved.');
  2348.                         exit(SaveOutline);
  2349.                     end;
  2350.                 SaveCoordinates := (RoiType = PolygonRoi) or (RoiType = FreehandRoi);
  2351.                 if SaveCoordinates then
  2352.                     if not CoordinatesAvailableMsg then begin
  2353.                             exit(SaveOutline);
  2354.                         end;
  2355.                 err := GetFInfo(fname, RefNum, TheInfo);
  2356.                 case err of
  2357.                     NoErr: 
  2358.                         if TheInfo.fdType <> 'Iout' then begin
  2359.                                 TypeMismatch(fname);
  2360.                                 exit(SaveOutline)
  2361.                             end;
  2362.                     FNFerr:  begin
  2363.                             err := create(fname, RefNum, 'Imag', 'Iout');
  2364.                             if CheckIO(err) <> 0 then
  2365.                                 exit(SaveOutline);
  2366.                         end;
  2367.                     otherwise
  2368.                         if CheckIO(err) <> 0 then
  2369.                             exit(SaveOutline);
  2370.                 end;
  2371.                 with hdr do begin
  2372.                         rID := 'Iout';
  2373.                         rVersion := version;
  2374.                         rRoiType := RoiType;
  2375.                         rRoiRect := RoiRect;
  2376.                         rNCoordinates := nCoordinates;
  2377.                         GetLoi(rX1, rY1, rX2, rY2);
  2378.                         rLineWidth := LineWidth;
  2379.                         for i := 1 to 14 do
  2380.                             rUnused[i] := 0;
  2381.                     end;
  2382.                 err := fsopen(fname, RefNum, f);
  2383.                 if CheckIO(err) <> 0 then
  2384.                     exit(SaveOutline);
  2385.                 err := SetFPos(f, FSFromStart, 0);
  2386.                 ByteCount := SizeOf(RoiHeader);
  2387.                 if ByteCount <> 64 then
  2388.                     PutMessage('Roi header size <> 32.');
  2389.                 err := fswrite(f, ByteCount, @hdr);
  2390.                 if SaveCoordinates then begin
  2391.                         ByteCount := nCoordinates * 2;
  2392.                         err := fswrite(f, ByteCount, ptr(xCoordinates));
  2393.                         ByteCount := nCoordinates * 2;
  2394.                         err := fswrite(f, ByteCount, ptr(yCoordinates));
  2395.                         DataSize := nCoordinates * 4;
  2396.                     end
  2397.                 else
  2398.                     DataSize := 0;
  2399.                 if CheckIO(err) <> 0 then begin
  2400.                         err := fsclose(f);
  2401.                         err := FSDelete(fname, RefNum);
  2402.                         exit(SaveOutline)
  2403.                     end;
  2404.                 err := SetEOF(f, SizeOf(RoiHeader) + DataSize);
  2405.                 err := fsclose(f);
  2406.                 err := GetFInfo(fname, RefNum, TheInfo);
  2407.                 if TheInfo.fdCreator <> 'Imag' then begin
  2408.                         TheInfo.fdCreator := 'Imag';
  2409.                         err := SetFInfo(fname, RefNum, TheInfo);
  2410.                     end;
  2411.                 err := FlushVol(nil, RefNum);
  2412.             end; {with info^}
  2413.     end;
  2414.  
  2415.  
  2416.     procedure OpenOutline (fname: str255; RefNum: integer);
  2417.         var
  2418.             err, f, i: integer;
  2419.             count: LongInt;
  2420.             hdr: RoiHeader;
  2421.             okay: boolean;
  2422.     begin
  2423.         if Info = NoInfo then begin
  2424.                 if (LongInt(NewPicWidth) * NewPicHeight) <= UndoBufSize then begin
  2425.                         if not NewPicWindow('Untitled', NewPicWidth, NewPicHeight) then
  2426.                             exit(OpenOutline)
  2427.                     end
  2428.                 else begin
  2429.                         beep;
  2430.                         exit(OpenOutline)
  2431.                     end;
  2432.             end;
  2433.         KillRoi;
  2434.         err := fsopen(fname, RefNum, f);
  2435.         with info^, hdr do begin
  2436.                 count := SizeOf(RoiHeader);
  2437.                 err := fsread(f, count, @hdr);
  2438.                 if rID <> 'Iout' then begin
  2439.                         err := fsclose(f);
  2440.                         PutMessage('File is corrupted.');
  2441.                         exit(OpenOutline)
  2442.                     end;
  2443.                 if (rRoiRect.right > PicRect.right) or (rRoiRect.bottom > PicRect.bottom) then begin
  2444.                         err := fsclose(f);
  2445.                         PutMessage('Image is too small for the outline.');
  2446.                         exit(OpenOutline)
  2447.                     end;
  2448.                 case rRoiType of
  2449.                     LineRoi:  begin
  2450.                             LX1 := rX1;
  2451.                             LY1 := rY1;
  2452.                             LX2 := rX2;
  2453.                             LY2 := rY2;
  2454.                             RoiType := LineRoi;
  2455.                             MakeRegion;
  2456.                             SetupUndo;
  2457.                             RoiShowing := true;
  2458.                         end;
  2459.                     RectRoi, OvalRoi:  begin
  2460.                             RoiType := rRoiType;
  2461.                             RoiRect := rRoiRect;
  2462.                             MakeRegion;
  2463.                             SetupUndo;
  2464.                             RoiShowing := true;
  2465.                         end;
  2466.                     PolygonRoi, FreehandRoi: 
  2467.                         if (rNCoordinates > 2) and (rNCoordinates <= MaxCoordinates) then begin
  2468.                                 count := rNCoordinates * 2;
  2469.                                 err := fsread(f, count, ptr(xCoordinates));
  2470.                                 count := rNCoordinates * 2;
  2471.                                 err := fsread(f, count, ptr(yCoordinates));
  2472.                                 if CheckIO(err) = 0 then begin
  2473.                                         nCoordinates := rNCoordinates;
  2474.                                         SelectionMode := NewSelection;
  2475.                                         if rVersion >= 148 then
  2476.                                             for i := 1 to nCoordinates do
  2477.                                                 with rRoiRect do begin
  2478.                                                         xCoordinates^[i] := xCoordinates^[i] + left;
  2479.                                                         yCoordinates^[i] := yCoordinates^[i] + top;
  2480.                                                     end;
  2481.                                         MakeOutline(rRoiType);
  2482.                                         SetupUndo;
  2483.                                     end;
  2484.                             end;
  2485.                 end;
  2486.             end;
  2487.         err := fsclose(f);
  2488.     end;
  2489.  
  2490.  
  2491.     function GetTIFFParameters (name: str255; RefNum: integer): boolean;
  2492.         var
  2493.             err: OSErr;
  2494.             f: integer;
  2495.             DirOffset: LongInt;
  2496.             TiffInfo: TiffInfoRec;
  2497.     begin
  2498.         GetTIFFParameters := false;
  2499.         err := fsopen(name, RefNum, f);
  2500.         if err <> NoErr then
  2501.             exit(GetTIFFParameters);
  2502.         if not OpenTiffHeader(f, DirOffset) then begin
  2503.                 err := fsclose(f);
  2504.                 exit(GetTIFFParameters)
  2505.             end;
  2506.         if not OpenTiffDirectory(f, DirOffset, TiffInfo) then begin
  2507.                 err := fsclose(f);
  2508.                 exit(GetTIFFParameters)
  2509.             end;
  2510.         with TiffInfo do begin
  2511.                 ImportCustomWidth := width;
  2512.                 ImportCustomHeight := height;
  2513.                 ImportCustomOffset := OffsetToData;
  2514.                 if BitsPerPixel = 16 then begin
  2515.                         ImportCustomDepth := SixteenBitsUnsigned;
  2516.                         ImportSwapBytes := IntelByteOrder;
  2517.                     end
  2518.                 else begin
  2519.                         ImportCustomDepth := EightBits;
  2520.                         ImportInvert := ZeroIsBlack;
  2521.                     end;
  2522.             end;
  2523.         WhatToImport := ImportCustom;
  2524.         err := fsclose(f);
  2525.         GetTIFFParameters := true;
  2526.     end;
  2527.  
  2528.  
  2529.     procedure GetXUnits (UnitsKind: UnitsType);
  2530.     begin
  2531.         with info^ do
  2532.             case UnitsKind of
  2533.                 Nanometers: 
  2534.                     xUnit := 'nm';
  2535.                 Micrometers: 
  2536.                     xUnit := '╡m';
  2537.                 Millimeters: 
  2538.                     xUnit := 'mm';
  2539.                 Centimeters: 
  2540.                     xUnit := 'cm';
  2541.                 Meters: 
  2542.                     xUnit := 'meter';
  2543.                 Kilometers: 
  2544.                     xUnit := 'km';
  2545.                 Inches: 
  2546.                     xUnit := 'inch';
  2547.                 feet: 
  2548.                     xUnit := 'ft';
  2549.                 Miles: 
  2550.                     xUnit := 'mile';
  2551.                 Pixels: 
  2552.                     xUnit := 'pixel';
  2553.                 otherwise
  2554.                     ;
  2555.             end;
  2556.     end;
  2557.  
  2558.  
  2559.     procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: double);
  2560.     begin
  2561.         with info^ do begin
  2562.                 if xunit = 'nm' then begin
  2563.                         UnitsKind := Nanometers;
  2564.                         UnitsPerCm := 10000000.0;
  2565.                     end
  2566.                 else if xUnit = '╡m' then begin
  2567.                         UnitsKind := Micrometers;
  2568.                         UnitsPerCm := 10000.0;
  2569.                     end
  2570.                 else if xUnit = 'mm' then begin
  2571.                         UnitsKind := Millimeters;
  2572.                         UnitsPerCm := 10.0;
  2573.                     end
  2574.                 else if xUnit = 'cm' then begin
  2575.                         UnitsKind := Centimeters;
  2576.                         UnitsPerCm := 1.0;
  2577.                     end
  2578.                 else if xUnit = 'meter' then begin
  2579.                         UnitsKind := Meters;
  2580.                         UnitsPerCm := 0.01;
  2581.                     end
  2582.                 else if xUnit = 'km' then begin
  2583.                         UnitsKind := Kilometers;
  2584.                         UnitsPerCm := 0.00001;
  2585.                     end
  2586.                 else if xUnit = 'inch' then begin
  2587.                         UnitsKind := Inches;
  2588.                         UnitsPerCm := 0.3937;
  2589.                     end
  2590.                 else if xUnit = 'ft' then begin
  2591.                         UnitsKind := feet;
  2592.                         UnitsPerCm := 0.0328083;
  2593.                     end
  2594.                 else if xUnit = 'mile' then begin
  2595.                         UnitsKind := Miles;
  2596.                         UnitsPerCm := 0.000006213;
  2597.                     end
  2598.                 else if xUnit = 'pixel' then begin
  2599.                         UnitsKind := pixels;
  2600.                         UnitsPerCm := 0.0;
  2601.                         SpatiallyCalibrated := false;
  2602.                     end
  2603.                 else begin
  2604.                         UnitsKind := OtherUnits;
  2605.                         UnitsPerCm := 0.0;
  2606.                     end;
  2607.             end;
  2608.     end;
  2609.  
  2610.  
  2611. end.